perm filename FORMAT.GSB[MAC,LSP] blob
sn#616156 filedate 1981-10-01 generic text, type T, neo UTF8
;Saturday July 18,1981 23:58 -*- Mode:Lisp; LSB:Format,Format -*-
;;;; Maclisp FORMAT
; For now, a bootstrap:
(eval-when (compile)
; Note that because of Multics LSB deficiencies, it is necessary
; for things to be ordered properly. This is the main reason
; why the documentation is so randomly ordered.
(cond ((status feature Multics)
(load ">udd>Mathlab>LSB>compilation-environment.lisp"))))
(module format format)
{(only-for PDP-10)
(declare (muzzled t) (setq use-strt7 t))
(cond ((fboundp 'ferror))
((equal (get 'ferror 'autoload) (get 'format 'autoload))
; Certain old things may think that FERROR comes with FORMAT.
(defun ferror n
(funcall autoload '(ferror . ((lisp) cerror)))
(apply 'ferror (listify n))))
((not (get 'ferror 'autoload))
(defprop ferror ((lisp) cerror) autoload)))
}
{(only-for Multics)
(eval-when (compile)
(or (sysp 'princ)
(*lexpr princ prin1 print terpri tyo format charpos linel))
)
}
{-- The documentation will be constructed in several sections, with
the intent of having them concatentated together again to make a
chapter of documentation.
PROLOG - the introduction, and the .defun of FORMAT and ?FORMAT.
OPS - .table of the operators
PUBDOC - other public functions/variables/descriptions/crap
IDEFS - documentation of things needed for "defining your own"
STRING - cruft having to do with FORMAT using "strings"
CHART - a one-page very brief listing of the commands
}
{(only-for PDP-10)
{-- This drives whether or not we will allow the format operator
properties to be subr pointers themselves. This is detected
by their being of typep RANDOM. so instead of doing
(defun (a format-ctl-one-arg) ...) one can do
(defun (a format-ctl-one-arg format-ctl-one-arg) ...)
and not have that random gratuitous unnecessary symbol.
NOTE! it does not work on Multics because of the way defun
gets redefined to hack &-keywords (if in fact the three-list
type of defun ever worked). So this conditional hack should
NOT be used on multics until that is fixed, if ever.
}
(forms-needed-for (intrasystem-compilation)
(sstatus feature Format-Subr-Properties))
}
{(divert-documentation-to prolog)
.chapter "Format"
.setq format-chapter chapter-number
.setq format-section-page section-page
.setq format-page page
.c This is the entire PROLOG documentation. FORMAT and ?FORMAT
.c are .defuned here explicitly.
.c Lots of stuff here is copied verbatim from the Lisp Machine
.c Manual.
.defun format destination control-string ε1(any-number-of∀ε*argsε1)ε*
ε3formatε* is used to produce formatted output. ε3formatε*
outputs the characters of ε2control-stringε*, except that tilde
("ε3~ε*") introduces a directive. The character after the tilde,
possibly preceded by arguments and modifiers, specifies what kind of
formatting is desired. Some directives use an element of ε2argsε*
to create their output.
.end←defun
.c Here we break off the .defun so we can hack semantically... (sigh)
The output is sent to ε2destinationε*. If
ε2destinationε* is ε3nilε*, a string
is created which contains the output (see section
⊗(string-section) on ε3formatε* and strings, ⊗(string-section-page)).
If ε2destinationε* is ε3tε*, the output is sent to the "default
output destination", which in Maclisp is the output filespec
ε3nilε*--the terminal (controlled by the variable ε3↑wε*) and
ε3outfilesε* (controlled by ε3↑rε*). With those exceptions,
ε2destinationε* may be any legitimate output file specification.
A directive consists of a tilde, optional decimal numeric parameters
separated by commas, optional colon ("ε3:ε*") and atsign ("ε3@ε*")
modifiers, and a single character indicating what kind of directive
this is. The alphabetic case of the character is ignored.
Examples of control strings:
.lisp
"~S" ; ε1This is an S directive with no parameters.ε*
"~3,4:@s" ; ε1This is an S directive with two parameters, 3 and 4,ε*
; ε1 and both the colon and atsign flags.ε*
.end←lisp
ε3formatε* includes some extremely complicated and specialized
features. It is not necessary to understand all or even most of its
features to use ε3formatε* efficiently. The beginner should
skip over anything in the following documentation that is not
immediately useful or clear. The more sophisticated features are
there for the convenience of programs with complicated formatting
requirements.
Sometimes a numeric parameter is used to specify a character,
for instance the padding character in a right- or left-justifying
operation. In this case a single quote (ε3'ε*) followed by the
desired character may be used as a numeric argument. For example,
you can use
.lisp
"~5,'0d"
.end←lisp
to print a decimal number in five columns with leading zeros (the
first two parameters to ε3~Dε* are the number of columns and the
padding character).
In place of a numeric parameter to a directive, you can put
the letter ε3vε*, which takes an argument from ε2argsε* as a
parameter to the directive. Normally this should be a number but it
doesn't really have to be. This feature allows variable column-widths
and the like. Also, you can use the character ε3#ε* in place of a
parameter; it represents the number of arguments remaining to be
processed.
It is possible to have a directive name of more than one
'setq multi-character-operator-page page
character. The name need simply be enclosed in backslashes
("ε3⊃\ε*"); for example,
.lisp
(format t "~\now\" (status daytime))
.end←lisp
As always, case is ignored here. There is no way to quote a backslash
in such a construct. No multi-character operators come with
ε3formatε*.
Note that the characters ε3@ε*, ε3#ε*, and ε3\ε* which
are used by ε3formatε* are special to the default Multics input
processor, and may need to be quoted accordingly when typed in
(normally, with ε3\ε*).
Once upon a time, various strange and wonderful
interpretations were made on ε2control-stringε* when it was neither
a string nor a symbol. Some of these are still supported for
compatibility with existing code (if any) which uses them; new code,
however, should only use a string or symbol for ε2control-stringε*.
This document describes an implementation of ε3formatε*
which is currently in use in Maclisp (both PDP-10 and Multics), and is
intended to be transported to NIL. It thus is oriented towards the
Maclisp dialect of Lisp. The behaviour of ε3formatε* operators
should be fairly consistent across Lisp dialects; entries documented
here other than ε3formatε*, however, exist only in the Maclisp
implementation at this time, although they could be added to other
ε3formatε* implementations without difficulty.
}
{(divert-documentation-to ops)
.section "The Operators"
Here are the operators.
.table 3 250 500
}
{(divert-documentation-to chart)
.headings off
This chart is intended only as a reminder of what ε3formatε*
operations are available. Most of the operators have additional
parameters and options which are not listed here.
.c Last number is leading between .items.
.table 3 300 1000 15
}
{(divert-documentation-to string)
.section "Format and Strings"
'setq string-section css-number
'setq string-section-page page
In the PDP-10 Maclisp implementation, ε3formatε* has
provision for using a user supplied ε3stringε* implementation.
Normally, ε3formatε* expects to use symbols. However, if ε3(fboundp
⊃'stringpε*) is true, then ε3formatε* will use the ε3stringpε*
'findex stringp
predicate to see if its argument is a string. If that
is the case, then the function ε3string-lengthε*
'findex string-length
will be used to find the size of the string, and ε3char-nε*
'findex char-n
will be
used to fetch characters out of the string. Both of these routines
should have been declared ε3fixnumε* when compiled (i.e⊃., be
ncallable). Internally, tests are ordered such that string-ness is
independent on atomic-ness. In addition, the ε3characterε*
'findex character
routine may be used to canonicalize something to a character code.
The Multics implementation is similar to the PDP-10 Maclisp
implementation, but uses different routines; ε3stringlengthε* to
get the size of the string (or symbol), and ε3getcharnε* to fetch a
character out of the string. The ε3characterε* routine is not used.
}
;;;; Bootstrap macros
{(only-for Multics)
; Multics doesn't have NTH and NTHCDR.
(define-private-routine (format-nthcdr (fixnum index) l)
(loop for subl on l for i from 0 below index finally (return subl)))
(define-private-open-codable-routine (format-nth (fixnum index) l)
(declarations (use-sublis-for-open-coding)
(needed-for macros interpretation) ; not in object segment
)
(car (format-nthcdr index l)))
}
{(except-for Multics)
(define-private-xmacro (format-nthcdr index l)
`(nthcdr ,index ,l))
(define-private-xmacro (format-nth index l)
`(nth ,index ,l))
}
(define-private-xmacro (format-catch
tag-or-list-of-tags
(any-number-of forms))
{-- Multics doesn't have *CATCH or *THROW.
(For *THROW we just fudge where necessary.)
PDP10 and NIL *CATCH can take a list of tags.
Lispm *CATCH only allows one "body" form.
All CATCH instances in format have constant tags. So we macroify
it thusly.
}
{(only-for Lispm)
(bindq basis `(progn . ,forms))
(cond ((atom tag-or-list-of-tags)
`(*catch ',tag-or-list-of-tags ,basis))
(t (loop for tt in tag-or-list-of-tags
do (setq basis `(*catch ',tt ,basis)))
basis))}
{(except-for Lispm)
{(only-for Multics)
(bindq basis `(progn . ,forms))
(cond ((atom tag-or-list-of-tags)
`(catch ,basis ,tag-or-list-of-tags))
(t (loop for tt in tag-or-list-of-tags
do (setq basis `(catch ,basis ,tt)))
basis))}
{(except-for Multics)
`(*catch ',tag-or-list-of-tags . ,forms)}})
{(only-for PDP-10)
{-- PDP10 Maclisp normally implements doublequoted frobnitzes as uninterned
symbols which self-evaluate. They get dumped out "properly" in the
fasl file. However, all uses in FORMAT are restricted such that they
only need to pseudo-self-evaluate when used, not when passed around.
So in the compiler, we turn them into squidified symbols; this has
the effect of keeping them as symbols, making them seem to
self-evaluate in the compiler, but not making the compiled output
contain lots of extra garbage.
}
(forms-needed-for (private-compilation)
(setsyntax '/" 'macro
'(lambda ()
(do ((ch (tyi) (tyi)) (l nil (cons ch l)))
((= ch #/")
(setq l (nreverse l))
(cond (compiler-state
(list squid (list 'quote (implode l))))
(t (setq l (maknam l)) (set l l))))
(and (= ch #//) (setq ch (tyi)))))))
{-- Similarly, we find that doing a STRT type PRINC is better than
a TYO of 2 args, in terms of amounts of inline code. So we do:}
(define-intrasystem-optimizer (tyo char (optional stream))
(and (or (fixp char)
(and (not (atom char))
(eq (car char) 'quote)
(fixp (setq char (cadr char)))))
(not (or (null stream)
(and (not (atom stream))
(eq (car stream) 'quote)
(null (cadr stream)))))
`(princ ',(ascii char) ,stream)))
}
;;;; Random Declarations, stringp stuff
; The following may be used, and either aren't defined here, or may be
; used before defined:
(declare-routine (ferror condition-name control-string
(any-number-of arguments))
(slow-and-hairy))
{(only-for PDP-10)
(declare-routine (stringp frob)
(value-type truthvalue))
(declare-routine (string-length string)
(value-type fixnum))
(declare-routine (char-n string (fixnum index))
(value-type character-code))
(declare-routine (character frob)
; (value-type character-code)
; Jonl's isn't declared properly yet
)
}
{(only-for PDP-10)
; We keep this because a call to (status feature foo) takes over 100.
; instructions simply to get to the MEMQ part, at which point the
; MEMQ of a typical feature list could take another 100. It will
; be set again at each major call into FORMAT if it is NIL.
(define-private-variable *format-in-string-environment?
(init (status feature string)))
}
(define-private-xmacro (format-stringp frob)
; to make the stringp test easier, based on the above flag:
{(only-for PDP-10) `(and *format-in-string-environment? (stringp ,frob))}
{(except-for PDP-10) `(stringp ,frob)})
;;;; Ramdom stream stuff
{(public-documentation)
.section "Other Entries"
}
{(only-for PDP-10)
; And here is some LAP code to help.
(define-private-routine (format-stream-ops x)
)
(lap-a-list
'((lap format-stream-ops subr)
(args format-stream-ops (nil . 1))
(defsym asar 0 ttsar 1 as*fil 40000 as*sfa 200000 tts*ty 400)
format-stream-ops
(movei ar1 0 a)
(jsp tt xfosp)
(ler3 0 (% sixbit |NOT FILE OR SFA!|))
(jrst 0 frob-is-file)
;;;(movei tt sfcali)
(setzb tt c)
(movei b 'which-operations)
(xct 0 @ 1 a)
(popj p)
frob-is-file
(movei a '(cursorpos charpos linel tyo terpri))
(move tt ttsar ar1)
(tlnn tt tts*ty)
(hrrz a 0 a)
(popj p)
nil))
}
{(except-for Maclisp)
(define-private-xmacro (format-stream-call stream op (any-number-of args))
`({NIL send} {Lispm funcall} ,stream ,op . ,args))
(define-private-routine (format-decode-output-stream stream)
{(only-for Lispm)
(dcls (open-code) (use-sublis-for-open-coding))
(si:decode-print-arg stream)
}
{(except-for Lispm)
(cond ((null stream) standard-output)
((or (eq stream 't) (eq stream #T)) terminal-io)
('t stream))
}
)
}
;;;; where we find the operators
{(divert-documentation-to idefs)
.section "Defining your own"
.setq define-your-own-section-page section-page
}
{(only-for Maclisp)
(define-private-variable *format-obarray
(default-init obarray))
}
{(except-for Maclisp)
(define-private-variable *format-package
(default-init package))
}
{(except-for Lispm)
(divert-forms-to (compilation-environment sysdcl)
(array* (notype (format-char-table ?))))
}
{(only-for NIL)
(define-intrasystem-variable *format-character-table
(data-type vector)
(default-init (loop with v = (make-vector 128.)
for x being the vector-elements of v using (index i)
do (vset v i (intern (string-upcase (to-string i))
*format-package))
finally (return v))))
(define-intrasystem-open-codable-routine (format-char-table (fixnum index))
(dcls (use-sublis-for-open-coding))
(vref *format-character-table index))
}
{(except-for NIL)
((lambda (n)
(array format-char-table t n)
(do ((obarray *format-obarray) (i 0 (1+ i))) ((= i n))
(store (format-char-table i)
(ascii (cond ((lessp #.(1- #/a) i #.(1+ #/z))
(- i #.(- #/a #/A)))
(t i))))))
{(only-for Lispm) 256.}
{(except-for Lispm) 128.})
}
{(intrasystem-documentation)
For convenience, one may use the following to define
ε3formatε* operators.
}
(define-private-routine (make-format-op-name name)
(dcls (needed-for public-compilation umacs))
(implode (loop for c in (if (fixp name) (list name) (exploden name))
collect (if (lessp #.(1- #/a) c #.(1+ #/z))
(- c #.(- #/a #/A))
c))))
(define-private-routine (make-format-realsym name)
(dcls (needed-for public-compilation umacs))
(if (= (flatc name) 1) `(format-char-table ,(getcharn name 1))
{(only-for Maclisp)
`((lambda (obarray)
{(only-for Multics) (make←atom ,(get←pname name))}
{(except-for Multics) (pnput ',(pnget name 7) t)})
*format-obarray)}
{(except-for Maclisp)
`(intern ,(get-pname name) *format-package)}))
(define-private-routine (make-format-op-setup name def-form prop)
(dcls (needed-for public-compilation umacs))
`(progn 'compile
,def-form
((lambda (x)
(or (eq x ',name)
(apply 'defprop
(list* x (car (remprop ',name ',prop)) '(,prop)))))
,(make-format-realsym name))))
(define-private-routine (make-format-propdef name propval propname)
(dcls (needed-for public-compilation umacs))
`(apply 'defprop (cons ,(make-format-realsym name)
'(,propval ,propname))))
(define-public-macro (define-format-op name arglist (body body-forms))
(dcls (divdoc idefs) (needed-for public-compilation umacs))
(setq name (make-format-op-name name))
(bindq newname () def-form () propname ())
(cond ((fixp arglist)
(make-format-propdef name arglist 'format-ctl-repeat-char))
('t (setq propname
(cond ((null (cdr arglist)) 'format-ctl-no-arg)
((atom (cdr arglist))
(setq arglist (list (cdr arglist) (car arglist)))
'format-ctl-multi-arg)
(t (setq arglist (list (cadr arglist)
(car arglist)))
'format-ctl-one-arg)))
(setq newname (list name propname
{Format-Subr-Properties propname}))
(setq def-form
(if (status feature lsb)
`(define-private-routine (,newname . ,arglist)
. ,body-forms)
`(defun ,newname ,arglist . ,body-forms)))
(make-format-op-setup name def-form propname))))
{(document-routine)
This may be used in two formats:
.lisp
(define-format-op ε2operatorε* ε2varlistε* ε2body-forms...ε*)
.end←lisp
and
.lisp
(define-format-op ε2operatorε* ε2fixnum-character-codeε*)
.end←lisp
The ε2operatorε* may be the fixnum code for a character, or a symbol
with the same print-name as the operator. Whichever, it is
canonicalized (into upper case) and will be interned into the same
obarray/package which ε3formatε* resides in.
For example, the ε3formatε* operator for ε2tildeε* could be
defined as
.lisp
(define-format-op /~ #/~)
.end←lisp
where "#/~" represents the fixnum character code for tilde.
.break
For the first format, the type of operator is determined by decoding
ε2varlistε*, which may have one of the following formats:
.table 3 250 500
.item (ε2params-varε*)
An operator of exactly zero arguments; ε2params-varε* will get
bound to the parameters list.
.item (ε2params-varε*∀∀ε2arg-varε*)
An operator of exactly one argument; ε2params-varε* will get bound
to the parameters list, and ε2arg-varε* to the argument.
.item (ε2params-varε*∀∀.∀∀ε2args-varε*)
An operator of a variable number of args; ε2params-varε* will get
bound to the parameters list, and ε2args-varε* to the remaining
arguments to ε3formatε* (or to the recursive ε3~⊃{ε*
'c matching "}"
arguments). The operator should return as its value some sublist of
ε2args-varε*, so that ε3formatε* knows how many were used.
.end←table
A definition for the appropriate function is produced with a bvl
derived from the variables in ε2varlistε* and a body of
ε2body-formsε*. (The argument ordering in the function produced is
compatible with that on the Lisp Machine, which is ε2arg-varε*
(if any) first, and then ε2params-varε*.)
}
{(only-for PDP-10)
(progn ; Non-modular piece of shit.
(defprop define-format-op |DEFINE-FORMAT-OP.RMac| macro)
(defprop |DEFINE-FORMAT-OP.RMac| ((lisp)format umacs) autoload)
)
}
(define-private-xmacro (format-op? frob)
`(getl ,frob '(format-ctl-one-arg format-ctl-no-arg
format-ctl-multi-arg format-ctl-repeat-char)))
{(only-for PDP-10)
(mapc '(lambda (x) (or (memq x putprop) (push x putprop)))
'(format-ctl-repeat-char format-ctl-one-arg
format-ctl-no-arg format-ctl-multi-arg))
}
(define-private-xmacro (define-autoload-op
name arglist divstream
(any-number-of body-forms))
{(except-for PDP-10) `(define-format-op ,name ,arglist . ,body-forms)}
{(only-for PDP-10)
(auxiliary-bindings newname propname)
(setq name (make-format-op-name name))
(cond ((fixp arglist)
(make-format-propdef name arglist 'format-ctl-repeat-char))
(t (setq newname (implode (append '(/f /m /t /.)
(exploden name)
'(/. /o /p /|)))
propname
(cond ((null (cdr arglist)) 'format-ctl-no-arg)
((atom (cdr arglist))
(setq arglist (list (cdr arglist) (car arglist)))
'format-ctl-multi-arg)
(t (setq arglist (list (cadr arglist) (car arglist)))
'format-ctl-one-arg)))
`(progn 'compile
(define-private-hack (,newname . ,arglist) ,divstream
. ,body-forms)
,(make-format-propdef name newname propname))))
})
(define-private-routine (hack-the-hack definition-fn prototype-call
divstream body-forms)
(dcls (needed-for macros compilation interpretation))
{(only-for PDP-10)
`(progn 'compile
(,definition-fn ,prototype-call
(dcls (needed-for ,divstream interpretation))
. ,body-forms)
(or (fboundp ',(car prototype-call))
(defprop ,(car prototype-call)
((lisp) format ,divstream) autoload)))}
{(except-for PDP-10)
`(,definition-fn ,prototype-call . ,body-forms)})
(define-private-xmacro (define-intrasystem-hack
prototype-call divstream (any-number-of forms))
(hack-the-hack 'define-intrasystem-routine prototype-call
divstream forms))
(define-private-xmacro (define-private-hack
prototype-call divstream (any-number-of forms))
(hack-the-hack 'define-private-routine prototype-call divstream forms))
(define-private-xmacro (define-hidden-hack
prototype-call divstream (any-number-of forms))
`(define-private-routine ,prototype-call
{(only-for PDP-10)
(declarations (needed-for ,divstream interpretation))}
. ,forms))
;;;; random variables
(define-public-variable standard-output
(divdoc idefs))
{(document-variable)
Output from ε3formatε* operators should be sent to the stream which
is the value of ε3standard-outputε*. In the Multics implementation
of ε3formatε*, this value may sometimes be an object which is not
suitable for being fed to standard Lisp output functions (e.g.,
ε3princε*); ε3formatε* has definitions of various output
functions which handle this case properly, and may be used for
defining operators which will work compatibly in Multics Maclisp.
They are documented below. Note that because of the way ε3formatε*
interprets its destination, it is not necessarily safe to recursively
call ε3formatε* on the value of ε3standard-outputε* in PDP-10
Maclisp. It ε2isε* safe, however, to use ε3?formatε*
(⊗(?format-fun)) instead, ε2orε* to call ε3formatε* with a
ε2destinationε* of the symbol ε3formatε*.
}
;;;; Gratuitous Documentation
{(divert-documentation-to idefs)
Maclisp ε3formatε* will also accept a ε2destinationε* of
ε3formatε* to mean "use the ε3formatε* destination already in
effect". This is primarily for the benefit of Multics Maclisp, since
there the value of ε3standard-outputε* cannot be passed around as a
stream. The ε3formatε* operator ε3nowε*, which prints the current
time, could be defined as
.lisp
(define-format-op now (params)
params ; unused
(let ((now (status daytime)))
(format 'format "~2,'0D:~2,'0D:~2,'0D"
(car now) (cadr now) (caddr now))))
.end←lisp
with the result that
.lisp
(format nil "The current time is ~\now\.")
.end←lisp
could produce the string
.lisp
"The current time is 02:59:00."
.end←lisp
}
;;;; More variables
;;;***** Note! Due to autoloading, diverted code should reference
;;; the OLD variables for some indeterminate time.
(define-public-variable format:colon-flag
(divdoc idefs))
(define-public-variable format:atsign-flag
(divdoc idefs))
{(only-for Maclisp)
(define-private-variable colon-flag)
(define-private-variable atsign-flag)
}
{(document-variables format:colon-flag format:atsign-flag)
These tell whether or not we have seen a colon or atsign respectively
while parsing the parameters to a ε3formatε* operator. They are
only bound in the toplevel call to ε3formatε*, so are only really
valid when the ε3formatε* operator is first called; if the operator
does more parameter parsing (like ε3~⊃[ε* does) their values should be
saved if they will be needed.
These variables used to be named just ε3colon-flagε* and
ε3atsign-flagε*. In the interest of transporting ε3formatε* code
to Lisp implementations with packages, their names have been changed.
Thus, in either implementation one references them with the
'cindex packages
"ε3format⊃:ε*" at the front of the name, which in Maclisp is just
part of the print-name.
}
;;;; parameter hacking
{(divert-documentation-to idefs)
The ε2paramsε* are passed in as a list. This list, however,
is temporary storage only. If it is going to be passed back, it
ε2must be copiedε*. In Maclisp and NIL, it is an ordinary list
which, in PDP-10 Maclisp, will be ε3reclaimε*ed after the operator
has run. On the Lisp Machine, it will be a list-pointer into an
ε3art-q-listε* array, possibly in a temporary area. Thus, although
it is safe to save values in this list with ε3rplacaε*, one should
not ever use ε3rplacdε* on it, either explicitly or implicitly (by
use of ε3nconcε* or ε3nreverseε*).
}
{-- to hack the params in a reasonable manner, we define a "list
buffer" which is something we can (1) queue elements on (2) retreive a
list from and (3) maybe reclaim the storage of.
}
(define-private-xmacro (format-make-list-buffer)
{(only-for Lispm) '(make-array nil 'art-q-list 1 '(0))}
{(except-for Lispm) '()})
{-- all of the following frobs assume that buffer will be a variable,
hence can be repeatedly eval'ed, setqed, etc.
}
(define-private-xmacro (format-push-list-buffer frob buffer)
{(only-for lispm) `(array-push-extend ,buffer ,frob)}
{(except-for lispm) `(push ,frob ,buffer)})
(define-private-xmacro (format-get-list-buffer-pointer buffer)
{(only-for lispm) `(g-l-p ,buffer)}
{(except-for lispm) `(setq ,buffer (nreverse ,buffer))})
(define-private-xmacro (format-reclaim-list-buffer buffer)
{(only-for Lispm)
`(return-array (prog1 ,buffer (setq ,buffer nil)))}
{(except-for Lispm)
{(only-for PDP-10) `(reclaim ,buffer (setq ,buffer nil))}
{(except-for PDP-10) buffer}})
;;;; Invocation...
{(divert-documentation-to idefs)
Conceptually, ε3formatε* operates by performing output to
some stream. In practice, this is what occurs in most
implementations; in Maclisp, there are a few special SFAs used by
ε3formatε*. This may not be possible in all implementations,
however. To get around this, ε3formatε* has a mechanism for
allowing the output to go to a pseudo-stream, and supplies a set of
functions which will interact with these when they are used.
}
{(except-for Lispm)
(define-private-variable *format-sfap)
}
;;;; Multics stream op hacks
{(only-for Multics)
(define-intrasystem-routine (format-icall0 op)
(let ((p (plist (cadr standard-output))))
(cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) standard-output op))
(t (funcall (cadr standard-output) standard-output op)))))
(define-intrasystem-routine (format-icall1 op arg1)
(let ((p (plist (cadr standard-output))))
(cond ((eq (car p) 'lsubr)
(lsubrcall nil (cadr p) standard-output op arg1))
(t (funcall (cadr standard-output) standard-output op arg1)))))
(define-intrasystem-routine (format-call0 s op)
(let ((p (plist (cadr s))))
(cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) s op))
(t (funcall (cadr s) s op)))))
(define-intrasystem-routine (format-call1 s op arg1)
(let ((p (plist (cadr s))))
(cond ((eq (car p) 'lsubr) (lsubrcall nil (cadr p) s op arg1))
(t (funcall (cadr s) s op arg1)))))
(define-public-routine (format-stream-default crock op arg1 rest)
(auxs t1 t2)
(selectq op
((princ prin1)
(setq t1 (typep arg1))
(cond ((cond ((eq op 'princ) (memq t1 '(string symbol)))
((eq t1 'symbol)
(= (setq t2 (stringlength arg1)) (flatsize arg1))))
(loop for i from 1 to (or t2 (stringlength arg1))
do (format-call1 crock 'tyo (getcharn arg1 i))))
(t (loop for x in (if (eq op 'princ) (exploden arg1)
(map '(lambda (x)
(rplaca x (CtoI (car x))))
(explode arg1)))
do (format-call1 crock 'tyo x)))))
(terpri (format-call1 crock 'tyo #\cr))
(fresh-line
(or (zerop (format-call0 crock 'charpos))
(format-call0 crock 'terpri)))
(formfeed (format-call1 crock 'tyo #\ff))
(tab-to
(setq t1 arg1 t2 (or (car rest) 1))
(let* ((here (format-call0 crock 'charpos))
(there (+ t1 (* (// (+ (- (if (> t1 here) t1 here) t1)
(1- t2))
t2)
t2))))
(declare (fixnum here there))
(loop repeat (- there here)
do (format-call1 crock 'tyo #\sp))))
(t (error "Not supported -- " (list* crock op arg1 rest)))))
}
;;;; Output partial definitions
(define-public-routine (format-tyo character)
(dcls (divdoc idefs))
{(except-for PDP-10)
{(only-for Multics)
(cond ((not (null *format-sfap)) (format-icall1 'tyo character))
((null standard-output) (tyo character))
(t (tyo character standard-output)))}
{(except-for Multics)
(dcls (open-code) (use-sublis-for-open-coding))
(tyo character)}
}
{(only-for PDP-10)
(dcls (assembly-language-definition))
(skipe 0 (special *format-sfap))
(jrst 0 format-tyo-to-sfa)
(push p a)
(push p (special standard-output))
(movni t 2)
(jcall 16 'tyo)
format-tyo-to-sfa
(movei c 0 a)
(movei b 'tyo)
(move a (special standard-output))
(movei tt sfcali)
(xct 0 @ 1 a)
(popj p)
}
)
{(document-routine)
ε3tyoε*s ε2characterε* to the ε3formatε* output destination.
}
(define-public-routine (format-princ object)
(dcls (divdoc idefs))
{(except-for PDP-10)
{(only-for Multics)
(cond ((not (null *format-sfap)) (format-icall1 'princ object))
((null standard-output) (princ object))
(t (princ object standard-output)))}
{(except-for Multics)
(dcls (open-code) (use-sublis-for-open-coding))
(princ object) ; standard-output is the default?
}
}
{(only-for PDP-10)
(dcls (assembly-language-definition))
(push p a)
(push p (special standard-output))
(movni t 2)
(jcall 14. 'princ)
}
)
{(document-routine)
ε3princε*s ε2objectε* to the ε3formatε* output destination.
}
{(only-for PDP-10)
(declare-variable squid)
(define-public-optimizer (format-princ x)
(and (cond ((atom x)
(or (and (fboundp 'stringp) (stringp x))
(and (symbolp x) (get x '+internal-string-marker))
(floatp x)))
((eq (car x) 'quote)
(setq x (cadr x))
(or (and (fboundp 'stringp) (stringp x))
(symbolp x)
(floatp x)))
((eq (car x) squid)
(and (not (atom (setq x (cadr x))))
(eq (car x) 'quote)
(symbolp (cadr x))
(setq x (cadr x)))))
`(princ ',x standard-output)))
}
(define-public-routine (format-prin1 object)
(dcls (divdoc idefs))
{(except-for PDP-10)
{(only-for Multics)
(cond ((not (null *format-sfap)) (format-icall1 'prin1 object))
((null standard-output) (prin1 object))
(t (prin1 object standard-output)))}
{(except-for Multics)
(dcls (open-code) (use-sublis-for-open-coding))
(prin1 object)}
}
{(only-for PDP-10)
(dcls (assembly-language-definition))
(push p a)
(push p (special standard-output))
(movni t 2)
(jcall 14. 'prin1)
}
)
{(document-routine)
ε3prin1ε*s ε2frobε* to the ε3formatε* output destination.
}
(define-public-routine (format-lcprinc string capitalize?)
(dcls (divdoc idefs))
{(only-for Maclisp)
(loop {(only-for Multics)
for i from 1 to (stringlength string)
as ch fixnum = (getcharn string i)
}
{(except-for Multics)
; Use exploden because it's the easiest way to support
; any kind of "string" or symbol.
with l = (exploden string)
for ch fixnum in l
}
when (lessp #.(1- #/A) (boole 1 ch #o137) #.(1+ #/Z))
do (setq ch (if capitalize? (boole 4 ch #o40)
(boole 7 ch #o40)))
do (format-tyo ch) (setq capitalize? ())
{(only-for PDP-10)
finally (reclaim l (setq l nil))
}
)
}
{(except-for Maclisp)
(loop for c being the {(only-for Lispm)
array-elements of (string string)
}
{(except-for Lispm)
characters of (to-string string)
}
do (format-tyo
(if capitalize? (char-upcase c) (char-downcase c)))
(setq capitalize? ()))
}
)
{(document-routine)
This outputs ε2stringε*, which must be a string or symbol, to the
ε3formatε* output destination in lower-case. If ε2capitalize⊃?ε*
is not ε3nilε*, then the first character is converted to upper case
rather than lower.
}
(define-public-routine (format-terpri)
(dcls (divdoc idefs))
{(only-for PDP-10)
(dcls (assembly-language-definition))
(push p (special standard-output))
(movni t 1)
(jcall 14. 'terpri)
}
{(except-for PDP-10)
{(only-for Multics)
(cond ((not (null *format-sfap))
(funcall (cadr standard-output) standard-output 'terpri))
((null standard-output) (terpri))
(t (terpri standard-output)))
}
{(except-for Multics)
(dcls (open-code) (use-sublis-for-open-coding))
(terpri)
}
}
)
{(document-routine)
Does a ε3terpriε* to the ε3formatε* output destination.
}
(define-public-routine (format-charpos)
(dcls (value-type fixnum) (divdoc idefs))
{(only-for PDP-10) (dcls (implement-as expr))}
{(except-for PDP-10)
{(only-for Multics)
(if (not (null *format-sfap)) (format-icall0 'charpos)
(charpos (or standard-output (null ↑w) (null ↑r)
(null outfiles) (car outfiles))))}
{(except-for Multics)
(bindq wops (format-stream-call standard-output ':which-operations)
tem (or (memq ':read-cursorpos wops) (memq ':charpos wops)))
(if tem (format-stream-call standard-output (car tem))
(ferror ()
"The stream ~S does not support a :CHARPOS-like operation"
standard-output))}})
(define-public-routine (format-linel)
(dcls (value-type fixnum) (divdoc idefs))
{(only-for PDP-10) (dcls (implement-as expr))}
{(except-for PDP-10)
{(only-for Multics)
(if (not (null *format-sfap)) (format-icall0 'linel)
(linel (or standard-output (null ↑w) (null ↑r)
(null outfiles) (car outfiles))))}
{(except-for Multics)
(bindq wops (format-stream-call standard-output ':which-operations)
tem (or (memq ':inside-width wops) (memq ':linel wops)))
(if tem (format-stream-call standard-output (car tem))
(ferror ()
"The stream ~S does not support a :LINEL-like operation"
standard-output))}})
{(document-routines format-charpos format-linel)
Return the ε3charposε* and ε3linelε* of the ε3formatε*
output destination. Since in the Maclisp implementation multiple
output destinations may be implicitly in use (via ε3outfilesε*, for
instance) this attempts to choose a representative one. The terminal
is preferred if it is involved.
}
{(only-for PDP10)
(lap-a-list
'((lap format-charpos subr)
(args format-charpos (nil . 0))
(push p (% 0 0 fix1))
(pushj fxp foo)
(njcall 14. 'charpos)
(entry format-linel subr)
(args format-linel (nil . 0))
(push p (% 0 0 fix1))
(pushj fxp foo)
(njcall 14. 'linel)
foo (skipn a (special standard-output))
(jrst 0 choose-default)
(movei t 0 a)
(lsh t -9.)
(skipge 0 st t)
(hlrz a 0 a)
bar (push p a)
(movni t 1)
(popj fxp)
choose-default
(skipn 0 (special ↑w))
(skipe 0 (special ↑r))
(jrst 0 baz)
default-is-tty
(move a (special tyo))
(jrst 0 bar)
baz (skipn a (special outfiles))
(jrst 0 default-is-tty)
(hlrz a 0 a)
(jrst 0 bar)
nil))
}
;;;; Maclisp "mapping" over streams
{(only-for Maclisp)
(define-private-routine (format-stream-map fn stream)
(bindq singlet nil list nil)
(cond ((null stream)
(or ↑w (setq singlet {PDP-10 tyo} {Multics t}))
(and ↑r (setq list outfiles)))
{(only-for PDP-10)
((atom stream)
(and (or (not ↑w) (not (eq stream t))) (setq singlet stream)))
(t (setq list stream))}
{(only-for Multics)
(t (setq singlet stream))}
)
(and singlet (funcall fn singlet))
(loop for x in list
when (or (not ↑w) (not (eq x t)))
do (funcall fn {PDP-10 (cond ((eq x t) tyo) (t x))} {Multics x})))
}
;;;; Fresh-line
(define-public-routine (format-fresh-line)
(dcls (divdoc idefs))
{(except-for Maclisp)
(bindq wops (format-stream-call standard-output ':which-operations)
tem ())
(cond ((memq ':fresh-line wops)
(format-stream-call standard-output ':fresh-line))
((and (setq tem (or (memq ':read-cursorpos wops)
(memq ':charpos wops)))
(zerop (format-stream-call standard-output (car tem)))))
('t (format-stream-call standard-output ':terpri)))
}
{(only-for Maclisp)
{(only-for Multics)
(if *format-sfap (format-icall0 'fresh-line)
(format-stream-map #'format-fresh-line-1 standard-output))
}
{(except-for Multics)
(format-stream-map #'format-fresh-line-1 standard-output)
}
}
)
{(only-for Maclisp)
(define-private-routine (format-fresh-line-1 stream)
{(only-for PDP-10)
(bindq ops (format-stream-ops stream))
(cond ((memq 'fresh-line ops) (sfa-call stream 'fresh-line nil))
((and (memq 'cursorpos ops) (cursorpos 'a stream)))
((or (not (memq 'charpos ops)) (plusp (charpos stream)))
(terpri stream)))
}
{(except-for PDP-10)
(or (zerop (charpos stream)) (terpri stream))
}
t
)
}
{(document-routine format-fresh-line)
This performs the ε3fresh-lineε* operation to the default
ε3formatε* destination. In PDP-10 Maclisp, this first will try the
ε3fresh-lineε* operation if the destination is an SFA and supports
it. Otherwise, if the destination is a terminal or an SFA which
supports ε3cursorposε*, it will try ε3(cursorpos 'a)ε*. Otherwise,
it will do a ε3terpriε* if the ε3charposε* is not ε30ε*. In the
Maclisp implementation, where multiple output destinations may be
implicitly involved (via ε3outfilesε*, for instance), this handles
each such destination separately.
}
;;;; tab-to
(define-private-xmacro (format-next-tabpos pos)
{(only-for Multics)
`(* (// (+ ,pos 9.) 10.) 10.)}
{(except-for Multics)
`(boole 4 (+ ,pos 8.) 7.)})
(define-public-routine (format-tab-to
(fixnum destination) (optional increment?)
{Lispm (optional units ':character)})
(dcls (divdoc idefs))
{(except-for Maclisp)
(bindq wops (format-stream-call standard-output ':which-operations)
(fixnum increment) (or increment? 1))
(cond ((memq ':tab-to wops)
(format-stream-call
standard-output ':tab-to destination increment
{Lispm units}))
((memq ':read-cursorpos wops)
(let (x y)
(multiple-value (x y)
(format-stream-call
standard-output ':read-cursorpos {Lispm units}))
(format-stream-call standard-output ':set-cursorpos
{Lispm units}
(+ destination
(* (// (+ (- (max destination x) destination)
(1- increment))
increment)
increment))
y)))
((and {Lispm (eq units ':character)} (memq ':charpos wops))
(let ((x (format-stream-call standard-output ':charpos)))
(do ((n (* (// (+ (- (max destination x) destination)
(1- increment))
increment)
increment)
(1- n)))
((zerop n))
(format-stream-call standard-output ':tyo #\sp))))
('t (format-stream-call standard-output ':string-out " ")))}
{(only-for Maclisp)
(dcls (implement-as lexpr n n))
{(only-for Multics)
(if *format-sfap
(format-icall2 'tab-to (arg 1) (or (and (> n 2) (arg 2)) 1))
(format-stream-map #'format-tab-to-1 (arg 1)))
}
{(except-for Multics)
(format-stream-map #'format-tab-to-1 standard-output)
}
}
't)
{(only-for Maclisp)
(define-private-routine (format-tab-to-1 s)
(bindq (fixnum here) 0 (fixnum there) 0 (fixnum dest) (arg 1)
(fixnum inc) (or (and (> (arg nil) 1) (arg 2)) 1))
(cond
{(only-for PDP-10)
((let ((ops (format-stream-ops s)))
(cond ((memq 'tab-to ops) (sfa-call s 'tab-to (cons dest inc)) t)
((not (memq 'charpos ops)) (princ '| | s) t))))
}
(t (setq here (charpos s))
(setq there (+ dest (* (// (+ (- (if (> dest here) dest here)
dest)
(1- inc))
inc)
inc)))
{-- Do we want to use tabs?
(loop as next fixnum = (format-next-tabpos here)
until (> next there)
do (tyo #\tab s) (setq here next))
}
(loop until (= here there)
do (tyo #\sp s) (setq here (1+ here)))))
t)
}
{(document-routine format-tab-to)
This implements ε3~Tε* to the current ε3formatε* destination (q.v.).
In PDP-10 Maclisp, this operation on an SFA will use the ε3tab-toε*
operation if it supported, passing in arguments of ε2destinationε*
and ε2incrementε* (as a dotted pair); otherwise, ε3charposε* will
be used to compute the number of spaces to be output. If
ε3charposε* is not supported, two spaces will be output.
}
;;;; formfeed
(define-public-routine (format-formfeed)
(dcls (divdoc idefs))
{(except-for Maclisp)
(bindq wops (format-stream-call standard-output ':which-operations)
tem ())
(cond ((setq tem (or (memq ':formfeed wops)
(memq ':clear-screen wops)))
(format-stream-call standard-output (car tem)))
((and (memq ':cursorpos wops)
(format-stream-call standard-output ':cursorpos 'c)))
('t (format-stream-call standard-output ':tyo #\ff)))}
{(only-for Maclisp)
{(only-for Multics)
(if *format-sfap (format-icall0 'formfeed)
(format-stream-map #'format-formfeed-1 standard-output))
}
{(except-for Multics)
(format-stream-map #'format-formfeed-1 standard-output)
}
}
't)
{(only-for Maclisp)
(define-private-routine (format-formfeed-1 s)
{(only-for PDP10)
(bindq ops (format-stream-ops s))
(cond ((memq 'formfeed ops) (sfa-call s 'formfeed format:colon-flag))
((and (memq 'cursorpos ops) (cursorpos 'c s)))
(t (tyo #\ff s)))}
{(except-for PDP-10) (tyo #\ff s)}
t)
}
{(document-routine format-formfeed)
Performs a ε3formfeedε* on the ε3formatε* output destination. In
Multics Maclisp, this will normally just ε3tyoε* the character code
for a formfeed. In PDP-10 Maclisp, this will use the ε3formfeedε*
operation if the destination is an SFA and supports it, otherwise it
will do a ε3(cursorpos 'c)ε* if the destination is a TTY file array
(or an SFA) and supports it, otherwise it simply outputs the character
code for a formfeed.
}
;;;; Character fetching hair.
; The "source" string:
(define-private-variable *format-string)
; the (0-origined) index into it:
(define-private-variable *format-string-index (data-type fixnum))
; the index will always be passed in and incremented explicitly.
; the size of the "string":
(define-private-variable *format-string-length (data-type fixnum))
; Here we have the problem that we may have strings, but we may not,
; and we must always handle symbols in their place. Hence, we have
; a special-variable which tells whether or not the "string" is a real
; string.
; We assume that the routine CHAR-N is the "canonical" way to get a
; character out of a "string" (as a fixnum character code). Lispm
; strings are special cased to use AR-1 (since they are 1-d arrays),
; and in PDP-10 Maclisp lap-code similar to GETCHARN (but without the error
; checking) is used.
{(only-for PDP-10)
; If we are hacking a "string", this is it (rather than just being T).
(define-private-variable *format-stringp)
}
(define-private-routine (format-get-char (fixnum index))
(dcls (value-type character-code))
{(except-for PDP-10)
(dcls (open-code) (use-sublis-for-open-coding))
{(only-for lispm)
(ar-1 *format-string index)
}
{(except-for Lispm)
{(only-for Multics)
(getcharn *format-string (1+ index))
}
{(except-for Multics)
(char-n *format-string index)
}
}
}
{(only-for PDP-10)
(dcls (assembly-language-definition))
(push p (% 0 0 fix1))
(skipe b (special *format-stringp))
(jrst 0 get-char-from-string)
(move tt 0 a)
(hlrz a @ (special *format-string))
(skipn 0 a)
(skipa a (% 0 0 '#.(pnget nil 7.)))
(hrrz a 1 a)
(idivi tt 5)
(jumpe tt foo)
lp (hrrz a 0 a)
(sojg tt lp)
foo (hlrz a 0 a)
(ldb tt byte-table d)
(popj p)
byte-table
(350700←22 0 0 a)
(260700←22 0 0 a)
(170700←22 0 0 a)
(100700←22 0 0 a)
(010700←22 0 0 a)
get-char-from-string
(exch a b)
; Perhaps use +INTERNAL-CHAR-N ???
(njcall 2 'char-n)
}
)
;;;; arguments
(define-intrasystem-variable *format-args)
{(document-variable)
This is the current value of the ε3formatε* ε2argumentsε*.
Whenever another is needed, it is ε3popε*ped off of this.
}
(define-intrasystem-variable *format-original-args)
{(document-variable)
This is the original value of ε3*format-argsε*. It is used whenever
we need to "back up", as with ε3~Gε*.
}
{--
Some stuff just ain't worth documenting or supplying as
"intrasystem" routines/macros, because then it would need to exist at
runtime. Since the format is defined, and the chance of them being
needed is minimal, the following crap stays private.
}
(define-private-routine (format-pop-one-arg)
{-- In the pdp-10 implementation we will lap code this so that
we can fit in a trivial error uuo (it used to not check at all).}
{(except-for PDP-10)
(if (null *format-args)
(format-err1 "ran out of args" *format-original-args)
(prog1 (car *format-args) (setq *format-args (cdr *format-args))))
}
{(only-for PDP-10)
(dcls (assembly-language-definition))
(skipn b (special *format-args))
(jrst 0 lose-lose)
(hlrz a 0 b)
(hrrz b 0 b)
(movem b (special *format-args))
(popj p)
lose-lose
(move a (special *format-original-args))
(move b (special *format-string))
(jsp t %xcons)
(move b (special standard-output))
(jsp t %xcons)
(movei b 'format)
(jsp t %xcons)
(erint 6 (% sixbit |FORMAT RAN OUT OF ARGS!|)) ; fail-act error
(popj p)
}
)
;;;; Errors
(define-intrasystem-routine (format-err short-message)
{(only-for Maclisp)
(let ((msg (format nil
{(only-for Multics)
"lisp: ~A at decimal pos ~D in format string "
}
{(except-for Multics)
"- ~A at decimal pos ~D in format string"
}
short-message *format-string-index)))
(error msg *format-string 'fail-act)
(error msg *format-string))}
{(except-for Maclisp)
{(only-for Lispm) (dcls (open-code) (use-sublis-for-open-coding))}
(ferror () "~A at pos ~D in format string ~S"
short-message *format-string-index *format-string)})
(define-intrasystem-routine (format-err1 short-message datum)
{(only-for Maclisp)
(let ((msg (format nil
{(only-for Multics)
"lisp: ~A~:[~; (decimal pos ~D in format string ~S)~] - "
}
{(except-for Multics)
"- ~A~:[~; (decimal pos ~D in format string ~S)~]"
}
short-message *format-string
*format-string-index *format-string)))
(error msg datum 'fail-act)
(error msg datum))}
{(except-for Maclisp)
{Lispm (dcls (open-code) (use-sublis-for-open-coding))}
(ferror ()
"~1g~S - ~0g~A~2g ~:[in format~;(decimal pos ~D in format string ~S)~]"
short-message datum *format-string
*format-string-index *format-string)})
(define-intrasystem-routine (format-call-op op params)
(auxs (suggestion (format-op? op)) (z (cadr suggestion)))
{-- Consider, for PDP-10, changing the FUNCALL to LEXPR-FUNCALL
with last arg of NIL, which is significantly faster, especially
in (*RSET T) mode which is pretty common.}
(selectq (car suggestion)
(format-ctl-one-arg
{(only-for Format-Subr-Properties)
(if (eq (typep z) 'random)
(subrcall nil z (format-pop-one-arg) params)
(funcall z (format-pop-one-arg) params))
}
{(except-for Format-Subr-Properties)
(funcall z (format-pop-one-arg) params)
})
(format-ctl-no-arg
{(only-for Format-Subr-Properties)
(if (eq (typep z) 'random)
(subrcall nil z params)
(funcall z params))
}
{(except-for Format-Subr-Properties)
(funcall z params)
}
)
(format-ctl-multi-arg
(setq *format-args
{(only-for Format-Subr-Properties)
(if (eq (typep z) 'random)
(subrcall nil z *format-args params)
(funcall z *format-args params))}
{(except-for Format-Subr-Properties)
(funcall z *format-args params)}))
(format-ctl-repeat-char
(format-repeat-char (format-character z) (or (car params) 1)))
(t (format-err1 "not defined as format op" op))))
{(document-routine)
This is the primitive routine for calling a ε3formatε* operator.
ε2opε* is the operator (a symbol), ε2paramsε* is the parameters
(as returned by ε3format-collect-paramsε*,
⊗(format-collect-params-fun), q.v.),
and ε2suggestion?ε* tells us if we already know if ε2opε* is
defined as a ε3formatε* operator. If it is non-ε3nilε*, it should
be the result of a ε3getlε* on ε2opε* of the appropriate list of
properties. This saves us from doing the ε3getlε* twice where it
has been done to see if ε2opε* is really a ε3formatε* operator.
this routine performs the appropriate manipulations of the
ε3formatε* ε2argumentsε*.
}
{-- For PDP-10, consider consolidating the following 2 routines into a
single lap-coded one...}
(define-intrasystem-routine (format-process-text)
{(only-for Lispm)
; Here we can use STRING-SEARCH-CHAR to find the "next" operator.
(bindq i (string-search-char *format-string #/~ *format-string-index))
(bindq s (nsubstring *format-string *format-string-index
(setq *format-string-index
(or i *format-string-length))))
(format-stream-call standard-output ':string-out s)
(not (null i))}
{(except-for Lispm)
; Here we must check char-at-a-time.
(loop for i from *format-string-index
while (< i *format-string-length)
as char fixnum = (format-get-char i)
when (= char #/~)
do (setq *format-string-index (1+ i))
(return 't)
do (format-tyo char)
finally (setq *format-string-index i))})
{(document-routine)
This processes ε2control-stringε* from wherever its "pointer" was up
to the next operator, or the end of the string. in the former case it
returns ε3tε* and leaves the "pointer" pointing at the character
after the tilde, otherwise it returns ε3nilε*. the characters are
"processed" by being copied to ε3standard-outputε*.
}
(define-intrasystem-routine (format-skip-text)
{(except-for Maclisp)
; here we can use string-search-char to find the "next" operator.
(bindq i (string-search-char *format-string #/~ *format-string-index))
(setq *format-string-index (or i *format-string-length))
(not (null i))}
{(only-for Maclisp)
; Here we must check char-at-a-time.
(loop for i from *format-string-index
while (< i *format-string-length)
when (= (format-get-char i) #/~)
do (setq *format-string-index (1+ i))
and return t
finally (setq *format-string-index i))})
{(document-routine)
This is just like ε3format-process-textε*, except the characters are
not copied to ε3standard-outputε*. It is used, for example, by
ε3~⊃[ε* to skip alternative strings.
}
(define-intrasystem-routine (format-collect-params)
(setq format:colon-flag () format:atsign-flag ()
{Maclisp colon-flag () atsign-flag ()})
(loop with params = (format-make-list-buffer)
and i fixnum = *format-string-index
and (n argp v?) (fixnum)
for ch fixnum = (format-get-char i)
do (cond ((lessp #.(1- #/0) ch #.(1+ #/9))
(setq argp t v? () n (+ (* n 10.) (- ch #/0))))
((= ch #/:)
(setq format:colon-flag 't)
{Maclisp (setq colon-flag 't)})
((= ch #/@)
(setq format:atsign-flag 't)
{Maclisp (setq atsign-flag 't)})
((= ch #/,)
(or v? (format-push-list-buffer (and argp n) params))
(setq argp () v? () n 0))
((= ch #/')
(cond ((not (null argp))
(format-push-list-buffer n params)
(setq argp () n 0)))
(format-push-list-buffer
(format-get-char (setq i (1+ i)))
params)
(setq v? 't))
('t (cond ((not (null argp))
(format-push-list-buffer n params)
(setq argp () n 0)))
(cond ((or (= ch #/V) (= ch #/v))
(format-push-list-buffer
(format-pop-one-arg) params)
(setq v? 't))
((= ch #/#)
(format-push-list-buffer
(length *format-args) params)
(setq v? 't))
('t (setq *format-string-index i)
(return params)))))
when (not (< (setq i (1+ i)) *format-string-length))
do (format-err "Malformed operator")))
{(document-routine)
This should be called to fetch the ε2paramsε* for the next operator.
The "pointer" in the ε2control-stringε* should be pointing at the
first character after the tilde, as it is after either
ε3format-process-textε* or ε3format-skip-textε* have been called
(and have returned ε3tε*). The params are returned in the
implementation dependent form described above. In addition,
ε3format:colon-flagε* and ε3format:atsign-flagε* will be set if
either of those modifiers were seen. Note that the use of the
"parameter" ε3vε* will cause the format ε2argumentsε* to get
popped; if you are "skipping" part of the ε2control-stringε*, you
probably want ε3format-skip-paramsε*, below.
}
(define-intrasystem-routine (format-skip-params)
(setq format:colon-flag () format:atsign-flag ()
{Maclisp colon-flag () atsign-flag ()})
(loop with paramsp and i fixnum = *format-string-index
for ch fixnum = (format-get-char i)
do (cond ((or (lessp #.(1- #/0) ch #.(1+ #/9))
(= ch #/,) (= ch #/v) (= ch #/V) (= ch #/#))
(setq paramsp 't))
((= ch #/:)
(setq format:colon-flag 't)
{Maclisp (setq colon-flag 't)})
((= ch #/@)
(setq format:atsign-flag 't)
{Maclisp (setq atsign-flag 't)})
((= ch #/') (setq i (1+ i)) (setq paramsp 't))
('t (setq *format-string-index i) (return paramsp)))
when (not (< (setq i (1+ i)) *format-string-length))
do (format-err "Malformed operator")))
{(document-routine)
This is the no-op variation of ε3format-collect-paramsε*. It does
not pop the ε3formatε* ε2argumentsε* if ε3vε* is seen and does
not collect the parameters, although it ε2doesε* set
ε3format:colon-flagε* and ε3format:atsign-flagε* if appropriate.
It returns ε3tε* if any parameters (other than the flags) were seen,
ε3nilε* otherwise.
}
(define-private-routine (format-intern spec)
; In Maclisp, spec is a list of character codes.
; Elsewhere, a string (probably nsubstring).
{(only-for Maclisp)
(loop for l on spec
as c fixnum = (car l)
when (lessp #.(1- #/a) c #.(1+ #/z))
do (rplaca l (- c #.(- #/a #/A))))
(let ((obarray *format-obarray))
{(only-for Multics) (implode spec)}
{(except-for Multics)
(prog1 (implode spec) (reclaim spec (setq spec nil)))})}
{(except-for Maclisp)
(let ((str (string-upcase spec)) (sym) (foundp))
(multiple-value (sym foundp) (intern-soft str *format-package))
(prog1 (if foundp sym (format-err1 "Not defined as format op" str))
{Lispm (return-array str)}))})
(define-intrasystem-routine (format-read-op)
(bindq (character-code ch) (format-get-char *format-string-index))
(setq *format-string-index (1+ *format-string-index))
(if (= ch #/\)
(format-intern
{(only-for Maclisp)
(loop with l = () for i from *format-string-index
when (= i *format-string-length)
do (format-err "Unbalanced backslashes")
until (= (setq ch (format-get-char i)) #/\)
do (push ch l)
finally (setq *format-string-index (1+ i))
(return (nreverse l)))}
{(except-for Maclisp)
(let ((i (string-search-char #/\ *format-string
*format-string-index)))
(if (null i) (format-err "Unbalanced backslashes")
(prog1 (nsubstring *format-string
*format-string-index (1- i))
(setq *format-string-index (1+ i)))))})
(format-char-table {(only-for Lispm) (ldb %%ch-char ch)}
{(except-for Lispm) ch})))
{(document-routine)
This "reads" the format operator we are processing. It should only be
called after either ε3format-collect-paramsε* or
ε3format-skip-paramsε* have been called. It also advances the
"pointer" into ε2control-stringε* appropriately.
}
{-- now we define the stuff to allow us to collect output as a "string".
for each implementation, we simply define a stream and some associated
variables and macros.
}
(define-private-xmacro (format-collect-string (any-number-of forms))
{(except-for Lispm)
`((lambda (*format-collecting-string standard-output
*format-string-charpos *format-sfap
*format-string-linel)
,@forms
(setq *format-collecting-string
(nreverse *format-collecting-string))
{(only-for PDP-10)
(prog1 (funcall *format-string-generator
*format-collecting-string)
(reclaim *format-collecting-string
(setq *format-collecting-string nil)))}
{(except-for PDP-10)
{(only-for Multics)
(funcall *format-string-generator *format-collecting-string)}
{(except-for Multics) (to-string *format-collecting-string)}})
nil *format-string-stream 0 t
((lambda (n) (declare (fixnum n)) (cond ((> n 69.) n) (t 69.)))
(linel nil)))}
{(only-for Lispm)
`((lambda (*format-collecting-string
standard-output
*format-string-charpos)
,@forms
(adjust-array-size *format-collecting-string
(array-active-length *format-collecting-string))
*format-collecting-string)
(make-array nil 'art-string 16. nil '(0)))})
(define-private-variable *format-collecting-string)
(define-private-variable *format-string-charpos
(data-type fixnum))
(define-private-variable *format-string-linel
(data-type fixnum))
; In Maclisp, we have yet another special hook into string
; simulation packages: we call this to "produce" a string from our
; output.
{(only-for Maclisp)
{(only-for Multics)
(define-private-routine (format-string-generator character-list)
(get←pname (maknam character-list)))
}
(define-public-variable *format-string-generator
(divert-documentation-to string)
(default-initialization
{(only-for Multics) 'format-string-generator}
{(except-for Multics) 'maknam}))
{(document-variable)
This variable, which exists only in the Maclisp implementation of
ε3formatε*, should have as its value a function to convert a list of
characters to a "string" to be returned by ε3formatε*. In the
PDP-10 implementation, this defaults to ε3maknamε*, but may be
modified if "strings" are being supported. In the Multics
implementation, it is a function which does
.lisp
(get←pname (maknam ε2character-listε*))
.end←lisp
and may be modified, if desired, to something more efficient. In the
PDP-10 implementation, the list of characters should neither be
modified nor returned to free storage, as it will be ε3reclaimε*ed.
The PDP-10 Maclisp hack of returning an uninterned symbol which has
itself as its value and a ε3+internal-string-markerε* property is
not handled here; it is done by the outer call to ε3formatε*
itself, and only if the returned "string" is a symbol and the value of
ε3*format-string-generatorε* is ε3maknamε*. This is done so as to
not add unnecessary overhead to internal uses of "strings" by
ε3formatε*.
The name of this variable differs from that of other user-accessible
ε3formatε* variables for historical reasons; it will not be
changed, because it only exists in Maclisp.
}}
;;;; the string-collecting streams
; in pdp-10 maclisp, an sfa:
{(only-for PDP-10)
(define-private-routine (fsfa/| s op arg)
(caseq op
(tyo
(cond ((< arg 0)
(or (> *format-string-linel (- *format-string-charpos arg))
(terpri s)))
(t (push arg *format-collecting-string)
(setq *format-string-charpos
(caseq arg
((#\cr #\ff) 0)
(#\lf *format-string-charpos)
(#\bs {-- (max (1- *format-string-charpos) 0)}
(cond ((plusp *format-string-charpos)
(1- *format-string-charpos))
(t 0)))
(#\tab
(format-next-tabpos *format-string-charpos))
(t (1+ *format-string-charpos)))))))
(formfeed (or (zerop *format-string-charpos) (terpri s)) (terpri s) t)
(charpos *format-string-charpos)
(linel *format-string-linel)
(which-operations '(tyo formfeed charpos linel))
(t (error '|Unhandled sfa operation in formatting to a string| op))))
(define-private-variable *format-string-stream
(initialization (sfa-create 'fsfa/| 0 '*format-string-stream)))}
{(only-for Multics)
(define-private-routine (fsfa/| s op (optional arg1) (any-number-of rest))
(caseq op
(tyo (push arg1 *format-collecting-string)
(setq *format-string-charpos
(caseq arg1
((#\cr #\ff) 0)
(#\lf *format-string-charpos)
(#\bs (max (1- *format-string-charpos) 0))
(#\tab (let ((new (+ *format-string-charpos 10.)))
(- new (\ new 10.))))
(t (1+ *format-string-charpos)))))
(charpos (cond ((null arg1) *format-string-charpos)
(t (setq *format-string-charpos arg1))))
(linel (cond ((null arg1) *format-string-linel)
(t (setq *format-string-linel arg1))))
(which-operations '(tyo charpos linel))
(t (format-stream-default s op arg1 rest))))
(define-private-variable *format-string-stream
(default-initialization '(format-stream fsfa/|)))}
;;;; NIL string-collecting string
{(only-for NIL)
umm uhh well uhh
}
{-- we also define a mechanism for finding out the "flatc" of something;
ie, the number of characters which are output via some arbitrary
printing of something. }
(define-public-macro (format-flatc (any-number-of forms))
(dcls (needed-for public-compilation umacs) (divdoc idefs))
`(let ((*format-flatc 0)
(standard-output *format-flatc-stream)
{(except-for Lispm) (*format-sfap 't)})
,@forms
*format-flatc))
{(only-for PDP-10)
(progn ; Another non-modular piece of shit.
(defprop format-flatc |FORMAT-FLATC.RMac| macro)
(defprop |FORMAT-FLATC.RMac| ((lisp) format umacs) autoload))}
(define-private-variable *format-flatc
(referenced-at-visibility-class public)
(data-type fixnum))
{(only-for PDP-10)
(define-private-routine (format-flatc-stream (unused s) op arg)
(caseq op
(tyo (or (< arg 0) (setq *format-flatc (1+ *format-flatc))))
(which-operations '(tyo))
(t (error '|is an illegal operation in a format-flatc| op))))}
{(only-for Multics)
(define-private-routine (format-flatc-stream
s op (optional arg1) (any-number-of rest))
(caseq op
(tyo (setq *format-flatc (1+ *format-flatc)))
(which-operations '(tyo))
(t (format-stream-default s op arg1 rest))))}
(define-private-variable *format-flatc-stream
(referenced-at-visibility-class public) ; see format-flatc
(initialization
{(only-for PDP-10)
(sfa-create #'format-flatc-stream 0 'format-flatc-stream)}
{(except-for PDP-10) '(format-stream format-flatc-stream)}))
{(document-routine format-flatc)
.lisp
(format-flatc ε2form1ε* ε2form2ε* ... ε2formnε*)
.end←lisp
The ε2formε*s are evaluated in an environment similar to that used
inside of ε3formatε*: the various ε3formatε* output-performing
routines such as ε3format-tyoε* and ε3format-princε* may be used
to "perform output". In all but the Multics Maclisp implementation,
ε3standard-outputε* will be a stream which simply counts the
characters output--it will only support the ε3tyoε* operation.
}
;;;; Toplevel Dispatches
(define-intrasystem-routine (format-one-string string-or-symbol)
(bindq *format-string string-or-symbol
*format-string-length 0
*format-string-index 0)
{(except-for Maclisp)
(or (stringp string-or-symbol)
(setq string-or-symbol (string string-or-symbol)))
}
(setq *format-string-length
{(only-for Maclisp)
{(only-for Multics) (stringlength string-or-symbol)}
{(except-for Multics) (flatc string-or-symbol)}}
{(except-for Maclisp) (string-length string-or-symbol)})
(loop while (format-process-text)
as params = (format-collect-params)
do (format-call-op
(format-read-op)
(format-get-list-buffer-pointer params))
(format-reclaim-list-buffer params)))
;;;; Interpret a format argument
(define-intrasystem-routine (format-interpret-arg arg)
(bindq format:colon-flag () format:atsign-flag ()
{Maclisp colon-flag () atsign-flag () {PDP-10 *format-stringp nil}})
{(only-for PDP-10)
(or *format-in-string-environment?
(and (fboundp 'stringp) (setq *format-in-string-environment? t)))
}
(cond ((symbolp arg)
(format-one-string {(only-for Maclisp) arg}
{(except-for Maclisp) (get-pname arg)}))
((format-stringp arg)
{PDP-10 (setq *format-stringp arg)} (format-one-string arg))
((atom arg) (format-err1 "Garbage format control string" arg))
('t (loop for frob in arg
do (if (not (eq (typep frob) 'list)) (format-princ frob)
(format-call-op
(if (format-op? (car frob)) (car frob)
(format-intern (exploden (car frob))))
(cdr frob)))))))
;;;; format-internal
(define-intrasystem-routine (format-internal stream control-string arglist)
(bindq *format-original-args arglist
*format-args arglist
*format-string () ; .see format-err1
)
(if (eq stream 'string)
(let ((str (format-collect-string
(format-catch (format-/:/↑-tag format-/↑-tag)
(format-interpret-arg control-string)))))
; This crock is so we
; (1) don't need to have a separate special function
; (2) don't generate extra garbage for internal uses
; of format-collect-string. Mechanism should be fixed up.
{(only-for PDP-10)
(and (symbolp str)
(eq *format-string-generator 'maknam)
(putprop (set str str) t '+internal-string-marker))
}
str)
(format-catch (format-/:/↑-tag format-/↑-tag)
(cond ((eq stream 'format) (format-interpret-arg control-string))
('t {(only-for PDP-10)
(and (not (atom stream))
(null (cdr stream))
(not (eq (car stream) t))
(setq stream (car stream)))
}
(let ((standard-output stream)
{(only-for Maclisp) (*format-sfap nil)})
{PDP-10 (setq *format-sfap (sfap stream))}
(format-interpret-arg control-string)))))))
;;;; Character hacks
(define-intrasystem-routine (format-character frob)
(declarations (value-type character-code))
{(only-for PDP-10)
(dcls (assembly-language-definition))
(push p (% 0 0 fix1))
format-character
(skipn t a)
(jrst 0 foo-baz)
(lsh t -9.)
(hrrz t st t)
(cain t 'fixnum)
(jrst 0 foo-bar)
(cain t 'symbol)
(jrst 0 foo-baz)
(skipn 0 (special *format-in-string-environment?))
(jrst 0 lose-lose)
(call 1 'character) ; jonl's isn't ncallable
foo-bar
(move tt 0 a)
(popj p)
lose-lose
(erint 2 (% sixbit |not a character!|))
(jrst 0 format-character)
foo-baz
(movei b '1)
(njcall 2 'getcharn)
}
{(except-for PDP-10)
{(only-for Multics)
(cond ((fixp frob) frob) (t (CtoI frob)))
}
{(except-for Multics)
(dcls (open-code) (use-sublis-for-open-coding))
(character frob)
}
}
)
{(document-routine)
This performs coerces its argument to a fixnum code for a character,
in a method dependent on the implementation.
}
(define-intrasystem-routine (format-repeat-char char (fixnum n))
(bindq (character-code c) (format-character char))
(loop repeat n do (format-tyo c)))
{(document-routine)
This outputs ε2charε* ε2nε* times.
}
;;;; FORMAT, ?FORMAT
(define-public-routine (format stream control-string (any-number-of frobs))
(declarations (slow-and-hairy))
{(except-for PDP-10)
(format-internal
(cond ((eq stream 't) ())
((null stream) 'string)
('t stream))
control-string frobs)})
(define-public-routine (?format destination control-string
(any-number-of frobs))
(declarations (slow-and-hairy))
{(except-for PDP-10)
(format-internal destination control-string frobs)})
{(only-for PDP-10)
; Eliminate user LSUBR calling sequence overhead, and at the same time
; get to use Lisp's LSUBR argument-number-checker.
(lap-a-list
'((lap format lsubr)
(args format (2 . 510.))
(jsp tt lwnack)
(#o777770←22 0 'format)
(jsp r frobnicate)
(skipn 0 a)
(movei a 'string)
(came a (special *:truth))
(cain a 't)
(setz a)
(jcall 3 'format-internal)
frobnicate
(setz a)
(addi t 2)
(skipn f t)
(jrst 0 foo)
lp (pop p b)
(jsp t %pdlxc)
(aojl f lp)
foo (movei c 0 a)
(pop p b)
(pop p a)
(jrst 0 0 r)
(entry ?format lsubr)
(args ?format (2 . 510.))
(jsp tt lwnack)
(#o777770←22 0 '?format)
(jsp r frobnicate)
(jcall 3 'format-internal)
nil))
}
{(document-routine)
This is equivalent to ε3formatε* except that ε2destinationε* is
interpreted like the second argument to ε3printε*--ε3nilε* means
"the default", and ε3tε* means "the terminal". This only exists in
Maclisp at the moment.
}
;;;; format-justify
{(intrasystem-documentation)
.subsection "Useful Internal Routines"
Here are various internal routines which may be of use to
ε3formatε* operators.
}
(define-intrasystem-routine (format-justify
how mincol? colinc? minpad? padchar?
function (any-number-of additional-args))
(declarations (slow-and-hairy))
(auxiliary-bindings
((fixnum mincol) (or mincol? 0))
((fixnum colinc) (or colinc? 1))
((fixnum minpad) (or minpad? 0))
((character-code padchar)
(if padchar? (format-character padchar?) #\sp))
((fixnum size) (if (not (plusp mincol))
(setq mincol 0)
(format-flatc (apply function additional-args))))
((fixnum leftpad)) ((fixnum rightpad)) ((fixnum fullpad)))
(and (< colinc 1) (setq colinc 1))
(and (< minpad 0) (setq minpad 0))
(setq fullpad (+ size minpad))
(and (< fullpad mincol)
(setq fullpad (+ fullpad (* colinc (// (+ (- mincol fullpad)
(1- colinc))
colinc)))))
;; Figure out how many pad characters we want:
(setq fullpad (- fullpad size))
;; and distribute them.
(selectq how
(right (setq leftpad fullpad))
(center (setq leftpad (// fullpad 2) rightpad (- fullpad leftpad)))
(t ; Default is left
(setq rightpad fullpad)))
(format-repeat-char padchar leftpad)
(apply function additional-args)
(format-repeat-char padchar rightpad)
{(only-for PDP-10) (reclaim additional-args (setq additional-args nil))})
{(document-routine)
This is the primitive routine for outputting something in a
fixed-width field. ε2howε* should be one of the atoms ε3leftε*,
ε3rightε*, or ε3centerε*. ε2functionε* is applied to
ε2additional-argumentsε* once to see how much space that output
will take, and then a second time amidst the appropriate padding.
ε2mincolε*, ε2colincε*, ε2minpadε*, and ε2padcharε* are used
as described under ε3~Aε* to determine the total amount of pad
characters necessary; in fact, ε3~aε* uses this routine.
}
;;;; Output some random object
(define-intrasystem-routine (format-lisp-object-op
object params printing-function)
(and format:colon-flag (null object)
(setq printing-function 'format-princ object "()"))
; Check for trivial special case:
(if (null params) (funcall printing-function object)
(format-justify (if format:atsign-flag 'right 'left)
(car params) ;mincol
(car (setq params (cdr params))) ;colinc
(car (setq params (cdr params))) ;minpad
(car (setq params (cdr params))) ;padchar
printing-function object)))
{(document-routine)
This is the routine which implements ε3~Aε* and ε3~Sε*.
ε2objectε* is the arg, ε2paramsε* the parameters, and
ε2printing-functionε* the ε3formatε* outputting function which
produces the output: for ε3~Aε* it is ε3format-princε* and for
ε3~Sε* it is ε3format-prin1ε*, for example. If
ε3format:colon-flagε* is not ε3nilε* and ε2objectε* is, then
this behaves as if ε2objectε* were the string ε3"()"ε* and
ε2printing-functionε* were ε3format-princε*--it prints ε3()ε*.
}
(define-format-op A (params arg)
(format-lisp-object-op arg params 'format-princ))
(define-format-op S (params arg)
(format-lisp-object-op arg params 'format-prin1))
{(divert-documentation-to ops)
.item ~A
ε2argε*, any Lisp object, is printed without slashification (like
ε3princε*). ε3~ε2nε*Aε* inserts spaces on the right, if
necessary, to make the column width at least ε2nε*.
ε3~ε2mincol,colinc,minpad,padcharε*Aε* is the full form of
ε3~Aε*, which allows aleborate control of the padding. The string
is padded on the right with at least ε2minpadε* copies of
ε2padcharε*; padding characters are then inserted ε2colincε*
characters at a time until the total width is at least ε2mincolε*.
The defaults are ε30ε* for ε2mincolε* and ε2minpadε*, ε31ε*
for ε2colincε*, and ε2spaceε* for ε2padcharε*. The atsign
modifier causes the output to be right-justified in the field instead
of left-justified. (The same algorithm for calculating how many pad
characters to output is used.) The colon modifier causes an ε2argε*
of ε3nilε* to be output as ε3()ε*.
.item ~S
This is identical to ε3~Aε* except that it uses ε3prin1ε* instead
of ε3princε*.
}
{(divert-documentation-to chart)
.item ~A
ε3princε*s ε2argε*.
.item ~S
ε3prin1ε*s ε2argε*.
}
;;;; Integer hackery
{(intrasystem-documentation)
The following are used to output integers.
}
(define-intrasystem-routine (format-tyo-digit (fixnum integer))
; Used by FLRMAT...
(setq integer
{(only-for NIL) (digit-char integer)}
{(except-for NIL) (+ integer (if (> integer 9.) #.(- #/A 10.) #/0))})
(format-tyo integer))
{(document-routine)
This takes what is presumed to be a single-digit integer, and outputs
that character to ε3standard-outputε*. For example, if ε2integerε*
is 5, the character "5" is output; if ε2integerε* is 12 (decimal),
the character "C" is output. ε2integerε* may be from 0 to 35
(decimal), inclusive.
}
(define-intrasystem-routine (format-integer
(integer integer) use-commas? output-sign?)
(bindq plusp 't)
(cond ((minusp integer) (setq integer (minus integer) plusp ())))
(and output-sign? (format-tyo (if plusp #/+ #/-)))
(format-integer-1 integer use-commas?))
{(document-routine)
This prints ε2integerε* to ε3standard-outputε* in the current
output radix. If ε2use-commas?ε* is not ε3nilε*, it is the
character code of the character to use for commas, and commas will be
output between each group of three digits. If ε2output-sign?ε* is
non-null, then the sign character is output (no matter what the sign
is), otherwise the sign is ignored.
}
(define-private-routine (format-integer-1 (integer integer) use-commas?)
(auxs ((fixnum nn))
((fixnum b2) (* base base))
((fixnum b3) (* b2 base))
(fl ()))
(cond ((not (lessp integer b3))
(format-integer-1 (quotient integer b3) use-commas?)
(setq nn (remainder integer b3) fl 't)
(and use-commas? (format-tyo use-commas?)))
('t (setq nn integer)))
(and (or fl (not (< nn b2))) (format-tyo-digit (\ (// nn b2) base)))
(and (or fl (not (< nn base))) (format-tyo-digit (\ (// nn base) base)))
(format-tyo-digit (\ nn base))
)
(define-intrasystem-routine (format-integer-in-base-op arg params radix)
(bindq *nopoint 't base radix)
{-- (only-for PDP-10)
(bindq f 'format-princ arglist ())
(and (fixp arg) (fixp radix)
(setq f 'format-integer
arglist (list (and format:colon-flag
(format-character
(or (caddr params) #/,)))
(or format:atsign-flag (minusp arg)))))
(lexpr-funcall 'format-justify
'right (car params) () () (cadr params) f arg arglist)}
(if (or (not (fixp arg)) (not (fixp radix)))
(format-justify
'right (car params) () () (cadr params) 'format-princ arg)
(format-justify
'right (car params) () () (cadr params) 'format-integer arg
(and format:colon-flag
(format-character (or (caddr params) #/,)))
(or format:atsign-flag (minusp arg)))))
{(document-routine)
This is the subroutine which does the appropriate things to implement
ε3~Dε* and ε3~Oε*, given the argument, parameters, and radix.
}
(define-format-op D (params arg)
(format-integer-in-base-op arg params 10.))
(define-format-op O (params arg)
(format-integer-in-base-op arg params 8.))
{(divert-documentation-to ops)
.item ~D
Decimal integer output.
ε2argε* is printed as a decimal integer.
ε3~ε2nε*,ε2mε*,ε2oε*Dε* uses a column width of
ε2nε*, padding on the left with pad-character ε2mε* (default of
space), using the character ε2oε* (default comma) to separate
groups of three digits. These commas are only inserted if the
ε3⊃:ε* modifier is present. Additionally, if the ε3@ε* modifier
is present, then the sign character will be output unconditionally;
normally it is only output if the integer is negative. If ε2argε*
is not an integer, then it is output (using ε3princε*)
right-justified in a field ε2nε* wide, using a pad-character of
ε2mε*, with ε3baseε* decimal and ε3ε7*ε*nopointε* bound to
ε3tε*.
.item ~O
Octal integer output. Just like ε3~Dε*.
}
{(divert-documentation-to chart)
.item ~D
Decimal integer printing
.item ~O
Octal integer printing.
}
;;;; Random operators
(define-format-op P ((unused params) . arglist)
(and format:colon-flag (setq arglist (format-argmove -1 arglist)))
(cond ((equal (car arglist) 1) (and format:atsign-flag (format-tyo #/y)))
(format:atsign-flag (format-princ "ies"))
('t (format-tyo #/s)))
(cdr arglist))
{(divert-documentation-to ops)
.item ~P
If ε2argε* is not ε31ε*, a lower-case "s" is printed. ("P" is for
"plural".) ε3~:Pε* does the same thing, after backing up an
argument (like "ε3~:*ε*", below); it prints a lower-case ε3sε* if
the ε2lastε* argument was not 1. ε3~@Pε* prints "y" if the
argument is 1, or "ies" if it is not. ε3~:@Pε* does the same thing,
but backs up first.
.break
Example:
.lisp
(format nil "~D Kitt~:@P" 3) => "3 Kitties"
.end←lisp
}
{(divert-documentation-to chart)
.item ~P
Pluralize. (Output "s" if ε2argε* not 1)
}
(define-intrasystem-routine (format-argmove (fixnum n) arglist)
(cond ((minusp n)
(setq n (+ (- (length *format-original-args) (length arglist)) n)
arglist *format-original-args)))
(format-nthcdr n arglist))
(define-format-op /* (params . arglist)
(bindq (fixnum n) (or (car params) 1))
(and format:colon-flag (setq n (- n)))
(format-argmove n arglist))
{(divert-documentation-to ops)
.item ~*
ε3~*ε* ignores one ε2argε*. ε3~ε2nε**ε* ignores the next ε2nε*
arguments. ε2nε* may be negative. ε3~:*ε* backs up one arg;
ε3~ε2nε*:*ε* backs up ε2nε* args.
}
{(divert-documentation-to chart)
.item ~ε2nε**
Ignores ε2nε* (default 1) args.
.item ~ε2nε*:*
Backs up ε2nε* (default 1) args.
}
(define-format-op G (params . arglist)
arglist ; unused
(format-nthcdr (or (car params) 0) *format-original-args))
{(divert-documentation-to ops)
.item ~ε2nε*G
"Goes to" the ε2nε*th argument. ε3~0Gε* goes back to the first
argument in ε2argsε*. Directives after a ε3~ε2nε*Gε* will take
sequential arguments after the one gone to. Note that this command,
and ε3~*ε*, only affect the "local" ε2argsε*, if "control" is
within something like ε3~⊃{ε*.
'c Matching ⊃}
}
{(divert-documentation-to chart)
.item ~ε2indexε*G
Go to the ε2indexε*th arg, zero-origined.
}
(define-intrasystem-routine (format-nterpri count?)
(loop repeat (or count? 1) do (format-terpri)))
{(document-routine)
This outputs ε2count?ε* newlines to ε3standard-outputε*. If
ε2count?ε* is ε3nilε*, ε31ε* is used.
}
(define-format-op /% (params)
(format-nterpri (car params)))
{(divert-documentation-to ops)
.item ~%
Outputs a newline. ε3~ε2nε*%ε* outputs ε2nε* newlines. No
argument is used.
}
{(divert-documentation-to chart)
.item ~%
Newline. Takes repeat count parameter.
}
(define-format-op /& (params)
(format-fresh-line)
(and (car params) (format-nterpri (1- (car params)))))
{(divert-documentation-to ops)
.item ~&
The ε3fresh-lineε* operation is performed on the output stream.
ε3~ε2nε*&ε* outputs ε3ε2nε*-1ε* newlines after the fresh-line.
The ε3fresh-lineε* operation says to do a ε3terpriε* unless the
cursor is at the start of the line. This operation will virtually
always succeed in Maclisp, since all Maclisp file arrays know their
ε3charposε*. Implemented by ε3format-fresh-lineε*,
⊗(format-fresh-line-fun).
}
{(divert-documentation-to chart)
.item ~&
Fresh-line. Takes repeat count parameter.
}
(define-format-op X #\sp)
{(divert-documentation-to ops)
.item ~X
Outputs a space. ε3~ε2nε*Xε* outputs ε2nε* spaces. No
argument is used.
}
(define-format-op /~ #/~)
{(divert-documentation-to ops)
.item ~~
Outputs a tilde. ε3~ε2nε*~ε* outputs ε2nε* tildes. No argument
is used.
}
{(divert-documentation-to chart)
.item ~X
output a space. Takes repeat count parameter.
.item ~~
output a tilde. Takes repeat count parameter.
}
(define-format-op #\newline ((unused params))
(cond (format:atsign-flag (format-terpri)))
(bindq (fixnum i) *format-string-index)
{(only-for PDP-10)
(and (< i *format-string-length)
(= (format-get-char i) #\linefeed)
(setq i (1+ i)))}
(and (not format:colon-flag)
(loop while (< i *format-string-length)
as ch fixnum = (format-get-char i)
while (or (= ch #\tab) (= ch #\space))
do (setq i (1+ i))))
(setq *format-string-index i))
{(divert-documentation-to ops)
.item ~ε2newlineε*
Tilde immediately followed by a carriage return ignores the carriage
return and any whitespace at the beginning of the next line. With a
ε3:ε*, the whitespace is left in place. With an ε3@ε*, the
carriage return is left in place. This directive is typically used
when a format control string is too long to fit nicely into one line
of the program:
.lisp
(format the-output-stream "~&This is a reasonably ~
long string~%")
.end←lisp
which is equivalent to ε3formatε*ing the string
.lisp
"~&This is a reasonably long string~%"
.end←lisp
}
{(divert-documentation-to chart)
.item ~ε2newlineε*
Ignore following whitespace. ε3@ε* says "but don't ignore the
ε2newlineε*", and ε3:ε* says "but don't ignore the whitespace".
}
(define-format-op /| ((unused params))
(format-formfeed))
{(divert-documentation-to ops)
.item ~⊃|
Outputs a formfeed. ε3~ε2nε*⊃|ε* outputs ε2nε* formfeeds. No
argument is used. This is implemented by ε3format-formfeedε*,
⊗(format-formfeed-fun).
}
{(divert-documentation-to chart)
.item ~⊃|
formfeed. Takes repeat count parameter.
}
(define-format-op t (params)
(format-tab-to
(or (car params) 1) (cadr params) ; () -> 1
{(only-for Lispm) (if format:colon-flag ':pixels ':characters)}))
{(divert-documentation-to ops)
.item ~T
Spaces over to a given column. The full form is
ε3~ε2destinationε*,ε2incrementε*Tε*, which will output
sufficient spaces to move the cursor to column ε2destinationε*. If
the cursor is already past column ε2destinationε*, it will output
spaces to move it to column ε2destinationε3+ε*incrementε7*ε*kε*,
for the smallest integer value ε2kε* possible. ε2incrementε*
defaults to ε31ε*. This is implemented by the ε3format-tab-toε*
function, ⊗(format-tab-to-fun).
}
{(divert-documentation-to chart)
.item ~ε2nε*T
Tab to column ε2nε*.
}
{--
(define-format-op q (params arg)
(apply arg params))
}
(putprop (format-char-table #/Q)
{(only-for (and PDP-10 Format-Subr-Properties))
(or (get '*apply 'subr) 'apply)}
{(except-for (and PDP-10 Format-Subr-Properties))
'apply}
'format-ctl-one-arg)
{(divert-documentation-to ops)
.item ~Q
ε3~Qε* uses one argument, and applies it as a function to
ε2paramsε*. It could thus be used to, for example, get a specific
printing function interfaced to ε3formatε* without defining a
specific operator for that operation, as in
.lisp
(format t "~&; The frob ~vQ is not known.~%"
frob 'frob-printer)
.end←lisp
The printing function should obey the conventions described in
⊗(define-your-own-section-page). Note that the function to ε3~Qε*
follows the arguments it will get, because they are passed in as
ε3formatε* parameters which get collected before the operator's
argument.
}
;;;; CASE - ~[ ... ~]
(define-private-variable *format-case-more?)
(define-format-op /[ (params . arglist)
(bindq *format-case-more? 't arg nil)
(cond ((not (null format:atsign-flag))
(cond (format:colon-flag (format-err "~:@[ is not defined"))
('t (cond ((car (setq *format-args arglist))
(format-case-process))
('t (format-case-skip)
(setq *format-args (cdr arglist))))
(and *format-case-more?
(format-err "~@[ should have no ~;")))))
((progn (setq arg (if (null params) (pop arglist) (car params))
*format-args arglist)
(not (null format:colon-flag)))
(and arg (format-case-skip))
(and *format-case-more? (format-case-process))
(loop while *format-case-more? do (format-case-skip)))
((not (fixp arg)) (format-err1 "bad arg to ~[" arg))
((and (= (format-get-char *format-string-index) #/~)
(let ((*format-string-index (1+ *format-string-index)))
(and (format-skip-params) (eq (format-read-op) '/;))))
(loop with saved-pos = (1+ *format-string-index) and params
do (setq *format-string-index saved-pos)
(setq params (format-collect-params))
(setq params (format-get-list-buffer-pointer params))
(format-read-op)
(cond ((if format:colon-flag
(or (null params) (member arg params))
(loop unless (< arg (car params))
unless (> arg (cadr params))
return 't
while (setq params (cddr params))))
(and *format-case-more? (format-case-process))
(loop while *format-case-more?
do (format-case-skip))
(return ()))
('t (setq saved-pos (format-case-skip))))))
('t (loop repeat (if (minusp arg) 259259. arg)
do (format-case-skip)
while (eq *format-case-more? 't))
(and *format-case-more? (format-case-process))
(loop while *format-case-more? do (format-case-skip))))
*format-args)
(define-private-routine (format-case-skip)
(loop with level fixnum = 0 and (saved-pos op tem)
unless (format-skip-text) do (format-err "Unterminated ~[")
do (setq saved-pos *format-string-index)
(format-skip-params)
(setq op (format-read-op))
(cond ((eq op '/[) (setq level (1+ level)))
((eq op '/])
(and (minusp (setq level (1- level)))
(return (setq *format-case-more? ()))))
((setq tem (assq op '((/{ . /}) (/< . />) (/( . /)))))
(format-skip-bracket tem))
((and (zerop level) (eq op '/;))
(and format:colon-flag (setq *format-case-more? '/;))
(return saved-pos)))))
(define-private-routine (format-skip-bracket pair)
{-- Returns T if nothing occurs between the bracketed operators,
NIL otherwise.}
(loop with rb = (cdr pair) and (op tem) and emptyp = 't
as empty-pos fixnum = (1+ *format-string-index)
unless (format-skip-text)
do (format-err1 "Unbalanced brackets" pair)
when (not (= empty-pos *format-string-index)) do (setq emptyp ())
do (format-skip-params)
(setq op (format-read-op))
when (eq op rb) return emptyp
do (setq emptyp ())
(cond ((setq tem (assq op '((/< . />) (/[ . /])
(/{ . /}) (/( . /)))))
(format-skip-bracket tem)
(setq emptyp ()))
((memq op ; Matched "{"
'(/] /) /> /}))
(format-err1 "Mismatched brackets" (cons op pair))))))
(define-private-routine (format-case-process)
(loop with params
unless (format-process-text) do (format-err "Unterminated ~[")
as saved-pos-before = *format-string-index
do (format-skip-params)
as saved-pos-after = *format-string-index
as op = (format-read-op)
{-- as saved-final-pos = *format-string-index}
do (cond ((eq op '/;)
(return (setq *format-string-index saved-pos-before)))
((eq op '/]) (return (setq *format-case-more? ())))
('t (cond ((= saved-pos-before saved-pos-after)
(setq params ()))
('t (setq *format-string-index saved-pos-before)
(setq params (format-collect-params))
{-- (setq *format-string-index
saved-final-pos)
}
(format-read-op)))
(format-call-op op
(and params
(format-get-list-buffer-pointer params)))
(and params (format-reclaim-list-buffer params))))))
{(divert-documentation-to ops)
.item ~⊃[
ε3~[ε2str0ε*~;ε2str1ε*~;ε2...ε*~;ε2strnε*~]ε* is a set of
alternative control strings. The alternatives (called ε2clausesε*)
are separated by ε3~;ε* and the construct is terminated by ε3~⊃]ε*.
For example, "ε3~[Siamese ~;Manx ~;Persian ~;Tortoise-Shell ~;Tiger
~;Yu-Hsiang ~]kittyε*". The ε2argε*th
alternative is selected; ε30ε* selects the first.
If a numeric parameter is given (i.e. ε3~ε2nε*⊃[ε*),
then the parameter is used instead of an argument
(this is useful only if the parameter is "ε3#ε*").
If ε2argε* is out of range no alternative is selected.
After the selected alternative has been processed, the control string
continues after the ε3~⊃]ε*.
~[ε2str0ε*~;ε2str1ε*~;ε2...ε*~;ε2strnε*~:;ε2defaultε*~] has a default case.
If the ε2lastε* ε3~;ε* used to separate clauses
is instead ε3~:;ε*, then the last clause is an "else" clause,
which is performed if no other clause is selected.
For example, "ε3~[Siamese ~;Manx ~;Persian ~;Tortoise-Shell ~;Tiger
~;Yu-Hsiang ~:;Unknown ~] kittyε*".
~[~ε2tag00ε*,ε2tag01ε*,ε2...ε*;ε2str0ε*~ε2tag10ε*,ε2...ε*;ε2str1...ε*~]
allows the clauses to have explicit tags. The parameters to each ε3~;ε*
are numeric tags for the clause which follows it. That clause is processed
which has a tag matching the argument. If ε3~:ε2a1ε*,ε2a2ε*,ε2b1ε*,ε2b2ε*,ε2...ε*;ε*
is used, then the following clause is tagged not by single values but
by ranges of values ε2a1ε* through ε2a2ε* (inclusive), ε2b1ε* through ε2b2ε*, etc.
ε3~:;ε* with no parameters may be used at the end to denote a default clause.
For example, "ε3~[~'+,'-,'*,'//;operator ~'A,'Z,'a,'z;letter ~'0,'9;digit ~:;other ~]ε*".
ε3~:[ε2falseε*~;ε2trueε*~]ε* selects the ε2falseε* control string
if ε2argε* is ε3nilε*, and selects the ε2trueε* control string otherwise.
ε3~@[ε2trueε*~]ε* tests the argument. If it is not ε3nilε*,
then the argument is not used up, but is the next one to be processed,
and the one clause is processed.
If it is ε3nilε*, then the argument is used up, and the clause is not processed.
.lisp
(setq prinlevel nil prinlength 5)
(format nil "~@[ PRINLEVEL=~D~]~@[ PRINLENGTH=~D]"
prinlevel prinlength)
=> " PRINLENGTH=5"
.end←lisp
}
{(divert-documentation-to chart)
.item ~⊃[
ε3~[ε2text1ε*~;ε2text2ε*~;...~]ε*
ε3formatε*s only the ε2argε*th text string.
.item ~;
Delimits text strings for ε3~⊃[ε* and ε3~<ε*.
}
;;;; Format Roman Numeral
(define-hidden-hack (format-print-roman-char (fixnum i) (fixnum x)) num
(format-tyo (format-nth (+ i x x) '(#/I #/V #/X #/L #/C #/D #/M))))
(define-hidden-hack (format-print-roman-1 (fixnum x) (fixnum n) oldp) num
(cond ((> x 9.)
(format-print-roman-1 (// x 10.) (1+ n) oldp)
(setq x (\ x 10.))))
(cond ((and (= x 9.) (not oldp))
(format-print-roman-char 0 n)
(format-print-roman-char 0 (1+ n)))
((= x 5) (format-print-roman-char 1 n))
((and (= x 4) (not oldp))
(format-print-roman-char 0 n)
(format-print-roman-char 1 n))
('t (cond ((> x 5) (format-print-roman-char 1 n) (setq x (- x 5))))
(loop repeat x do (format-print-roman-char 0 n)))))
;;;; Number print in English
{(except-for Maclisp)
(define-private-variable *format-small-english-numbers)
(define-private-xmacro (format-small-english-numbers (fixnum i))
{(only-for NIL)
`(vref *format-small-english-numbers ,i)
}
{(except-for NIL)
`(aref *format-small-english-numbers ,i)
}
)
}
{(only-for Maclisp)
(divert-forms-to (compilation-environment sysdcl)
(array* (notype (format-small-english-numbers 19.))))}
(divert-forms-to (num interpreter)
((lambda (list)
{(only-for NIL)
(setq *format-small-english-numbers (to-vector list))
}
{(except-for NIL)
(fillarray
{(only-for Maclisp)
(array format-small-english-numbers t 19.)
}
{(except-for Maclisp)
(setq *format-small-english-numbers (*array nil t 19.))
}
list)})
'(("one" . "first") ("two" . "second") ("three" . "third")
("four" . "fourth") ("five" . "fifth") ("six" . "sixth")
("seven" . "seventh") ("eight" . "eighth") ("nine" . "ninth")
("ten" . "tenth") ("eleven" . "eleventh") ("twelve" . "twelfth")
("thirteen" . "thirteenth") ("fourteen" . "fourteenth")
("fifteen" . "fifteenth") ("sixteen" . "sixteenth")
("seventeen" . "seventeenth") ("eighteen" . "eighteenth")
("nineteen" . "nineteenth"))))
(define-intrasystem-hack (format-print-english n ordinalp) num
(cond ((minusp n) (format-princ "minus ") (setq n (minus n))))
(cond ((zerop n)
(format-princ "zero")
(and ordinalp (format-princ "th")))
((and (lessp 1099. n 10000.) (plusp (\ (// n 100.) 10.)))
(format-print-english-1 (// n 100.) ())
(format-princ " hundred")
(cond ((plusp (setq n (\ n 100.)))
(and ordinalp (format-princ " and"))
(format-tyo #\sp)
(format-print-english-1 n ordinalp))
(ordinalp (format-princ "th"))))
('t (format-print-english-1 n ordinalp))))
{(document-routine)
This is the primitive for printing integers in "english", as with
ε3~Rε* and ε3~:Rε*.
}
(define-hidden-hack (format-print-english-1 (integer n) ordinalp) num
(auxiliary-bindings
(q ())
(no-illion-flag 't)
(l '((1000000. . "m") (1000000000. . "b") (1000000000000. . "tr")
(1000000000000000. . "quadr") (1000000000000000000. . "quint")
(1000000000000000000000. . "sext")
(1000000000000000000000000. . "sept")
(1000000000000000000000000000. . "oct")
{--
(1000000000000000000000000000000. . "non")
(1000000000000000000000000000000000. . "dec")
(1000000000000000000000000000000000000. . "undec")
(1000000000000000000000000000000000000000. . "duodec")
(1000000000000000000000000000000000000000000. . "tredec")
(1000000000000000000000000000000000000000000000. . "quattuordec")
(1000000000000000000000000000000000000000000000000. . "quindec")
(1000000000000000000000000000000000000000000000000000. . "sexdec")
(1000000000000000000000000000000000000000000000000000000.
. "septdec")
})))
(cond ((zerop n))
((not (lessp n 1000.))
(setq q '(1000. . "thousand"))
(do () ((or (null l) (lessp n (caar l))))
(setq q (car l) l (cdr l) no-illion-flag ()))
(format-print-english-1 (quotient n (car q)) ())
(format-tyo #\sp)
(format-princ (cdr q))
(or no-illion-flag (format-princ "illion"))
(cond ((plusp (setq n (remainder n (car q))))
(format-tyo #\sp)
(and ordinalp (lessp n 100.) (format-princ "and "))
(format-print-english-1 n ordinalp))
(ordinalp (format-princ "th"))))
((< n 20.)
(setq q (format-small-english-numbers (1- n)))
(format-princ (if ordinalp (cdr q) (car q))))
((< n 100.)
(format-princ (format-nth (- (// n 10.) 2)
'("twent" "thirt" "fort" "fift"
"sixt" "sevent" "eight" "ninet")))
(cond ((and (zerop (setq n (\ n 10.))) ordinalp)
(format-princ "ieth"))
('t (format-tyo #/y)
(cond ((plusp n)
(format-tyo #/-)
(setq q (format-small-english-numbers (1- n)))
(format-princ
(if ordinalp (cdr q) (car q))))))))
('t ;; (< n 1000.)
(format-print-english-1 (// n 100.) ())
(format-princ " hundred")
(cond ((plusp (setq n (\ n 100.)))
(format-tyo #\sp)
(and ordinalp (format-princ "and "))
(format-print-english-1 n ordinalp))
(ordinalp (format-princ "th"))))))
;;;; ~R - print number in various ways
(define-autoload-op R (params arg) num
(cond ((not (null (car params)))
(format-integer-in-base-op arg (cdr params) (car params)))
('t (setq arg (fix arg))
(if atsign-flag
(if (lessp 0 arg (if colon-flag 5000. 4000.))
(format-print-roman-1 arg 0 colon-flag)
(let ((base 10.) (*nopoint 't)) (format-princ arg)))
(format-print-english arg colon-flag)))))
{(divert-documentation-to ops)
.item ~R
'c I quote, once more:
If there is no parameter, then ε2argε* is printed as a cardinal English number, e.g. four.
With the colon modifier, ε2argε* is printed as an ordinal number, e.g. fourth.
With the atsign modifier, ε2argε* is printed as a Roman numeral, e.g. IV.
With both atsign and colon, ε2argε* is printed as an old Roman numeral, e.g. IIII.
If there is a parameter, then it is the radix in which to print the number.
The flags and any remaining parameters are used as for the ε3~Dε* directive.
Indeed, ε3~Dε* is the same as ε3~10Rε*. The full form here is therefore
ε3~ε2radixε*,ε2mincolε*,ε2padcharε*,ε2commacharε*Rε*.
}
{(divert-documentation-to chart)
.item ~R
cardinal number printing
.item ~:R
ordinal number printing
.item ~@R
roman numeral printing
.item ~@:R
old-roman numeral printing
.item ~ε2nε*R
Like ε3~Dε*, using radix ε2nε*
}
;;;; ~C - output a character in various forms
(define-public-variable format:*top-char-printer
(default-init ()))
(define-format-op c ((unused params) arg)
(auxs ((character-code ch) (format-character arg))
(chname (format-get-chname ch)))
(cond ((not colon-flag)
(if (not atsign-flag) (format-tyo ch)
(lbind (((fixnum bucky) (boole 1 (lsh ch -7.) 3)))
(format-tyo #/#)
(cond ((not chname)
; super ascii-only crock. Should be fixed.
(or (zerop bucky)
(format-tyo (if (= bucky 3) 6 (1+ bucky))))
(setq ch (boole 1 ch 127.))
(setq chname (format-get-chname ch))))
(cond ((not (null chname))
(format-tyo #/\)
(format-lcprinc chname ()))
('t (format-tyo #//) (format-tyo ch))))))
('t (cond ((and (not chname) (plusp (boole 4 ch 127.)))
; try once without the bits. this is really for help.
(and (plusp (boole 1 ch #o200)) (format-princ "Control-"))
(and (plusp (boole 1 ch #o400)) (format-princ "Meta-"))
(and (plusp (boole 1 ch #o4000)) (format-princ "Top-"))
(setq chname (format-get-chname
(setq ch (boole 1 ch 127.))))))
(if (null chname) (format-tyo ch)
; If we hit any 2-char (or less!) names, we probably
; don't want them mixed-case, eg "Bs".
(if (> (flatc chname) 2)
(format-lcprinc chname 't)
; Actually the following isn't strictly correct
; for multics, where chname will really be in
; lower-case, and we want it in upper...
(format-princ chname)))
(and atsign-flag
format:*top-char-printer
(funcall format:*top-char-printer ch chname)))))
(define-private-variable *format-chnames
(default-init
'({-- Provide defaults for all format-effectors}
(backspace . #\backspace)
(tab . #\tab)
(space . #\space)
(form . #\form)
(linefeed . #\linefeed)
(return . #\return)
(form . #\form)
{-- Rubout is fairly special}
(rubout . #\rubout)
{-- bell doesn't display too nicely}
(bell . {(only-for Multics) 7} {(except-for Multics) #\bell})
{-- a few random things}
(help . #\help)
{-- Altmode is fairly important as it occurs in control-char range}
(altmode . #\altmode)
)))
{(except-for PDP-10)
(define-private-variable format:*/#-var
(default-init {(only-for Multics) '/#/\-alist}
{(except-for Multics) '/#-symbolic-characters-table}))
}
(define-private-routine (format-get-chname (character-code ch))
{(except-for PDP-10)
{(only-for Maclisp)
(or (and (boundp format:*/#-var)
(loop for pair in (symeval format:*/#-var)
when (= (cdr pair) ch) return (car pair)))
(loop for pair in *format-chnames
when (= (cdr pair) ch) return (car pair)))
}
{(except-for Maclisp)
(cdr (or (and (boundp format:*/#-var)
(rassoc ch (symeval format:*/#-var)))
(rassoc ch *format-chnames)))
}
}
{(only-for PDP-10)
(dcls (assembly-language-definition))
(move tt 0 a)
(hrrz b (special /#-symbolic-characters-table))
(caie b makunbound)
(jsp t lookup-one-frob)
(move b (special *format-chnames))
(jsp t lookup-one-frob)
(setz a)
(popj p)
lookup-one-frob
(jumpe b 0 t)
(hlrz a 0 b)
(hrrz c 0 a)
(hrrz b 0 b)
(came tt 0 c)
(jrst 0 lookup-one-frob)
(hlrz a 0 a)
(popj p)
}
)
{(divert-documentation-to ops)
.item ~C
ε2argε* is coerced to a character code. With no modifiers, ε3~Cε*
simply outputs this character. ε3~@Cε* outputs the character so it
can be read in again using the ε3#ε* reader macro: if there is a
named character for it, that will be used, for example
"ε3#\Returnε*"; if not, it will be output like "ε3#/Aε*".
ε3~:Cε* outputs the character in human-readable form, as in
"Return", "Meta-A". ε3~:@Cε* is like ε3~:Cε*, and additionally
might (if warranted and if it is known how) parenthetically state how
the character may be typed on the user's keyboard.
To find the name of a character, ε3~Cε* looks in two places. The
first is the value of the symbol which is the value of
ε3format:*/#-varε*,
'vindex format:*/#-var
which is initialized to be the variable which the ε3#ε* reader macro
uses. It is not necessary for the value of ε3format:*/#-varε* to be
bound. The second place is ε3*format-chnamesε*; this is used
primarily to handle non-printing characters, in case the ε3#ε*
reader macro is not loaded. Both of these are a-lists, of the form
ε3((ε2nameε* . ε2codeε*) (ε2nameε* . ε2codeε*) ...)ε*.
The Maclisp/NIL ε3formatε* has no mechanism for telling how a
particular character needs to be typed on a keyboard, but it does
provide a hook for one. If the value of ε3format:*top-char-printerε*
'vindex format:*top-char-printer
is not ε3nilε*, then it will be called as a function on two arguments: the character code, and the character name. If there were bucky-bits present, then they will have been stripped off unless there was a defined name for the character with the bits present. The function should do nothing in normal
cases, but if it does it should output two spaces, and then the
how-to-type-it-in description in parentheses. See
⊗(define-your-own-section-page) for information on how to do output
within ε3formatε*.
}
{(divert-documentation-to chart)
.item ~C
Outputs the character ε2argε*.
.item ~:C
Outputs the name of the character ε2argε*.
}
;;;; ~< - justify things in a field
(define-autoload-op /< (params) brack
(auxiliary-bindings
((fixnum mincol)) ((fixnum colinc)) ((fixnum minpad))
((fixnum padchar)) ((fixnum total-width) 0) ((fixnum frob-count) 0)
((fixnum fullpad)) (op) (left-space? colon-flag)
((fixnum total-space)) (right-space? atsign-flag) ((fixnum n))
(prefix) ((fixnum prefix-size)) (frobs) (tem) (semi-params))
(setq mincol (or (car params) 0)
colinc (or (car (setq params (cdr params))) 1)
minpad (or (car (setq params (cdr params))) 0)
padchar (format-character (or (cadr params) #\sp)))
(format-catch format-/↑-tag
(loop with saved-pos fixnum = 0
until (eq op '>) do
(setq tem (format-collect-string
(loop while (format-process-text)
do (setq params (format-collect-params)
op (format-read-op))
(if (memq op '(/; />)) (return ())
(format-call-op
op
(format-get-list-buffer-pointer params)))
(format-reclaim-list-buffer params)
finally
(format-err "Unterminated ~< in format string"))
(setq saved-pos *format-string-charpos)))
(cond ((or (eq op '/>) (not colon-flag) prefix frobs)
(push tem frobs)
(setq total-width (+ total-width (flatc tem))))
('t (setq semi-params (format-get-list-buffer-pointer params)
prefix-size saved-pos
prefix tem)))))
(or (eq op '/>)
{-- If we terminated early due to a ~↑, then we must flush the
remaining stuff.}
(format-skip-bracket '(/< . />)))
{-- We by default put in N-1 breaks for N segments:}
(setq frob-count (1- (length (setq frobs (nreverse frobs)))))
(and left-space? (setq frob-count (1+ frob-count)))
(and right-space? (setq frob-count (1+ frob-count)))
{-- But if there are no flags and only one segment, we right-justify:}
(and (zerop frob-count) (setq left-space? 't frob-count 1))
{-- Now, figure out just how many pad characters we need.}
(setq total-space (+ total-width (* frob-count minpad)))
(setq total-space
(if (< total-space mincol) mincol
(+ mincol (* colinc (// (+ (- total-space mincol) (1- colinc))
colinc)))))
{-- Maybe output the prefix on a new line.}
(cond ((not (null prefix))
(lbind (((fixnum linel) (or (cadr semi-params) (format-linel)))
((fixnum charpos) (format-charpos)))
(and (car semi-params)
(setq linel (- linel (car semi-params))))
(cond ((and (not (zerop linel))
(not (< total-space (- linel charpos)))
(> charpos (+ (flatc prefix) prefix-size)))
(format-princ prefix))))))
(setq fullpad (- total-space total-width))
(cond (left-space?
(setq n (// fullpad frob-count)
fullpad (- fullpad n)
frob-count (1- frob-count))
(format-repeat-char padchar n)))
(loop for frob in frobs
do (format-princ frob)
when (plusp frob-count)
do (setq n (// fullpad frob-count)
fullpad (- fullpad n)
frob-count (1- frob-count))
(format-repeat-char padchar n)))
{(divert-documentation-to ops)
.item ~<
ε3~ε2mincolε*,ε2colincε*,ε2minpadε*,ε2padcharε*<ε2textε*~>ε*
justifies ε2textε* within a field ε2mincolε* wide. ε2textε* may
be divided up into segments with ε3~⊃;ε*--the spacing is evenly
divided between the text segments. With no modifiers, the leftmost
text segment is left justified in the field, and the rightmost text
segment right justified; if there is only one, as a special case, it
is right justified. The colon modifier causes spacing to be
introduced before the first text segment; the atsign modifier causes
spacing to be added after the last. ε2minpadε*, default ε30ε*, is
the minimum number of ε2padcharε* (default space) padding characters
to be output between each segment. If the total width needed to
satisfy these constraints is greater than ε2mincolε*, then
ε2mincolε* is adjusted upwards in ε2colincε* increments.
ε2colincε* defaults to ε31ε*. For example,
.lisp
(format nil "~10<foo~;bar~>") => "foo bar"
(format nil "~10:<foo~;bar~>") => " foo bar"
(format nil "~10:@<foo~;bar~>") => " foo bar "
(format nil "~10<foobar~>") => " foobar"
(format nil "~10:@<foobar~>") => " foobar "
(format nil "$~10,,,'*<~3f~>" 2.59023) => "$******2.59"
.end←lisp
If ε3~↑ε* is used within a ε3~<ε* construct, then only the clauses
which were completely processed are used. For example,
.lisp
(format nil "~15<~S~;~↑~S~;~↑~S~>" 'foo)
=> " FOO"
(format nil "~15<~S~;~↑~S~;~↑~S~>" 'foo 'bar)
=> "FOO BAR"
(format nil "~15<~S~;~↑~S~;~↑~S~>" 'foo 'bar 'baz)
=> "FOO BAR BAZ"
.end←lisp
If the first clause of a ε3~<ε* is terminated with ε3~:;ε* instead of
ε3~;ε*, then it is used in a special way. All of the clauses are
processed (subject to ε3~↑ε*, of course), but the first one is omitted
in performing the spacing and padding. When the padded result has
been determined, then if it will fit on the current line of output, it
is output, and the text for the first clause is discarded. If,
however, the padded text will not fit on the current line, then the
text for the first clause is output before the padded text. The first
clause ought to contain a carriage return. The first clause is always
processed, and so any arguments it refers to will be used; the
decision is whether to use the resulting piece of text, not whether to
process the first clause. If the ε3~:;ε* has a numeric parameter
ε2nε*, then the padded text must fit on the current line with ε2nε*
character positions to spare to avoid outputting the first clause's
text. For example, the control string
.lisp
"~%;; ~{~<~%;; ~1:; ~S~>~↑,~}.~%"
.end←lisp
can be used to print a list of items separated by commas, without
breaking items over line boundaries, and beginning each line with
"ε3;;⊃ ε*". The argument 1 in ε3~1:;ε* accounts for the width of the
comma which will follow the justified item if it is not the last
element in the list, or the period if it is. If ε3~:;ε* has a second
numeric parameter, then it is used as the width of the line,
thus overriding the natural line width of the output stream. To make
the preceding example use a line width of 50, one would write
.lisp
"~%;; ~{~<~%;; ~1,50:; ~S~>~↑,~}.~%"
.end←lisp
Note that the segments ε3~<ε* breaks the output up into are computed
"out of context" (that is, they are first recursively ε3formatε*ted
into strings). Thus, it is not a good idea for any of the segments to
contain relative-positioning commands (such as ε3~Tε* and ε3~&ε*),
or any line breaks. If ε3~:;ε* is used to produce a prefix string,
it also should not use relative-positioning commands.
}
{(divert-documentation-to chart)
.item ~<
Spaces multiple text segments in a field.
}
;;;; ~{ ... ~} - iterate
(define-private-variable *format-iteration-hack)
(define-private-variable *format-iteration-args)
(define-autoload-op /{ (params . arglist) brack ; matching "}"
(bindq (fixnum starting-position) *format-string-index
(fixnum ending-position) 0
(fixnum count) (or (car params) 259259.)
/: colon-flag /@ atsign-flag
*format-iteration-hack ())
(setq *format-iteration-hack (if (format-skip-bracket '(/{ . /}))
(pop arglist)
starting-position)
ending-position *format-string-index)
(cond ((not (null /:))
(if (not (null /@))
(setq arglist (format-multiple-iterations arglist count))
(format-multiple-iterations (pop arglist) count)))
((not (null /@))
(setq *format-args arglist)
(format-many-iterations count)
(setq arglist *format-args))
('t (let ((*format-args (car arglist))
(*format-original-args (car arglist)))
(format-many-iterations count)
(setq arglist (cdr arglist)))))
(setq *format-string-index ending-position)
arglist)
(define-hidden-hack (format-multiple-iterations arglist (fixnum count)) brack
(bindq *format-iteration-args (or arglist (and colon-flag '(())))
*format-original-args ()
*format-args ())
(format-catch format-/:/↑-tag
(loop repeat count
while *format-iteration-args
do (setq *format-original-args
(setq *format-args (car *format-iteration-args))
*format-iteration-args (cdr *format-iteration-args))
(format-catch format-/↑-tag (format-one-iteration))))
*format-iteration-args)
(define-hidden-hack (format-many-iterations (fixnum count)) brack
(and (null *format-args) (not colon-flag) (setq count 0))
(format-catch (format-/:/↑-tag format-/↑-tag)
(loop with *format-iteration-args
repeat count
do (format-one-iteration)
while *format-args)))
(define-hidden-hack (format-one-iteration) brack
(if (fixp *format-iteration-hack)
(loop with (op params)
and *format-string-index = *format-iteration-hack
unless (format-process-text)
do (format-err "Unbalanced braces")
do (setq params (format-collect-params) op (format-read-op))
; Matching "{"
when (eq op '/}) return ()
do (format-call-op op (format-get-list-buffer-pointer params))
(format-reclaim-list-buffer params))
(format-interpret-arg *format-iteration-hack)))
{(divert-documentation-to chart)
.item ~⊃{
'c Matching ⊃}
Repeatedly formats a string - one arg, things to iterate over
.item ~:⊃{
'c Matching ⊃}
One arg - a list of lists to iterate over
.item ~@⊃{
'c Matching ⊃}
Iterates over remaining arguments
.item ~:@⊃{
'c Matching "⊃}"
Iterates over each of the remaining args, which are lists
}
{(divert-documentation-to ops)
.item ~⊃{ε2str∀ε*~⊃}
.c The merging of the italic "r" and bold "~" loses on XGP, so a ↑T is used.
This is an iteration construct. The argument should be a list,
which is used as a set of arguments as if for a recursive call to
ε3formatε*. The string ε2strε* is used repeatedly as the control
string. Each iteration can absorb as many elements of the list as it
likes. If before any iteration step the list is empty, then the
iteration is terminated. Also, if a numeric parameter ε2nε* is
given, then there will be at most ε2nε* repetitions of processing of
ε2strε*.
ε3~:⊃{ε2strε*~⊃}ε* is similar, but the argument should be a list
of sublists. At each repetition step one sublist is used as the set
of arguments for processing ε2strε*; on the next repetition a new
sublist is used, whether or not all of the last sublist had been
processed.
ε3~@⊃{ε2strε*~⊃}ε* is similar to ε3~⊃{ε2strε*~⊃}ε*, but
instead of using one argument which is a list, all the remaining
arguments are used as the list of arguments for the iteration.
ε3~:@⊃{ε2strε*~⊃}ε* combines the features of
ε3~:⊃{ε2strε*~⊃}ε* and ε3~@⊃{ε2strε*~⊃}ε*. All the
remaining arguments are used, and each one must be a list. On each
iteration one argument is used as a list of arguments.
Terminating the repetition construct with
'c Matching ⊃{
ε3~:⊃}ε*
instead of
'c Matching ⊃{
ε3~⊃}ε*
forces ε2strε* to be processed at least once even if the initial
list of arguments is null (however, it will not override an explicit
numeric parameter of zero).
If ε2strε* is null, then an argument is used as ε2strε*. It must be
a string, and precedes any arguments processed by the iteration. As
an example, the following are equivalent:
.lisp
(apply (function format) (list* stream string args))
(format stream "~1{~:}" string args)
.end←lisp
This will use ε3stringε* as a formatting string. The ε3~1⊃{ε* says
it will be processed at most once, and the ε3~:⊃}ε* says it will be
processed at least once. Therefore it is processed exactly once,
using ε3argsε* as the arguments.
.c Matching ⊃{
.item ~⊃}
Terminates a ε3~⊃{ε*. It is undefined elsewhere.
.c Matching ⊃}
}
;;;; ~↑ - (conditional) non-local exit
(define-format-op /↑ (params . arglist)
(and (if (car params)
(if (cadr params)
(if (caddr params)
(and (not (> (car params) (cadr params)))
(not (> (caddr params) (cadr params))))
(= (car params) (cadr params)))
(zerop (car params)))
(if format:colon-flag
(null *format-iteration-args)
(null arglist)))
{(except-for Multics)
(*throw (if format:colon-flag 'format-/:/↑-tag 'format-/↑-tag)
())}
{(only-for Multics)
(if format:colon-flag
(throw nil format-/:/↑-tag)
(throw nil format-/↑-tag))})
arglist)
{(divert-documentation-to ops)
.item ~↑
'c I quote, from the Lispm manual:
This is an escape construct. If there are no more arguments remaining
to be processed, then the immediately enclosing ε3~⊃{ε*
'c matching "}"
or ε3~<ε* construct is terminated. (In the latter case, the ε3~<ε*
formatting ε2isε* performed, but no more clauses are processed before
doing the justification. The ε3~↑ε* should appear only at the
ε2beginningε* of a ε3~<ε* clause, because it aborts the entire
clause. It may appear anywhere in a ε3~⊃{ε*
'c Matching "}"
construct.) If there is no such enclosing construct, then the entire
formatting operation is terminated.
If a numeric parameter is given, then termination occurs if the parameter
is zero. (Hence ε3~↑ε* is the same as ε3~#↑ε*.) If two parameters are
given, termination occurs if they are equal. If three are given, termination
occurs if the second is between the other two in ascending order.
If ε3~↑ε* is used within a ε3~:⊃{ε*
'c Matching "}"
construct, then it merely terminates
the current iteration step (because in the standard case it tests for
remaining arguments of the current step only); the next iteration step
commences immediately. To terminate the entire iteration process,
use ε3~:↑ε*.
}
{(divert-documentation-to chart)
.item ~↑
Terminate ~⊃{ or ε3formatε* if no args left
'c Matching ⊃}
}
;;;; Floating-point format stuff
(define-private-xmacro (define-floormat-maxmin
name type generic-fn specific-fn comparison-fn)
type generic-fn specific-fn comparison-fn ; inhibit unused warnings
`(define-private-open-codable-routine (,name (,type a) (,type b))
(dcls (needed-for interpretation macros)
(value-type ,type)
; Sorry, not yet supported well:
{(except-for Multics) (do-argument-type-checking)}
(do-argument-number-checking))
{(only-for Maclisp)
(cond ((,comparison-fn a b) a) (t b))
}
{(except-for Maclisp)
(dcls (use-sublis-for-open-coding))
{(only-for Lispm)
(,generic-fn ,a ,b)
}
{(except-for Lispm)
(,specific-fn ,a ,b)
}
}
))
(define-floormat-maxmin floormat-max& fixnum max max& >)
(define-floormat-maxmin floormat-min& fixnum min min& <)
(define-floormat-maxmin floormat-max$ flonum max max$ >)
(define-floormat-maxmin floormat-min$ flonum min min$ <)
(define-intrasystem-xstructure (floormat
conc-name
tree ; don't make hunks!
default-pointer)
mant expt sigdig tsigdig)
(define-intrasystem-hack (floormat-haulong (fixnum n)) float
(dcls (value-type fixnum))
(setq n (abs n))
(bindq (fixnum count) 1) ; PDP10 complr bug
(loop until (< n 10.) do (setq n (// n 10.) count (1+ count)))
count)
(define-hidden-hack (floormat-resize
floormat (fixnum digits-wanted)
dont-move-decimal-point-offset?)
float
(dcls (returnable))
(bindq (fixnum mant) (floormat-mant)
(fixnum expt) (floormat-expt)
(fixnum sigdig) (floormat-sigdig)
(fixnum msign) 1)
(and (= sigdig digits-wanted) (return floormat))
(and (minusp mant) (setq mant (- mant) msign -1))
(bindq (fixnum dif) (- digits-wanted sigdig))
(if (plusp dif)
(setq mant (* mant (↑ 10. dif)) expt (- expt dif))
(lbind* (((fixnum factor) (↑ 10. (setq dif (- dif))))
((fixnum r) (\ mant factor))
((fixnum half) (// factor 2)))
(setq mant (// mant factor) expt (+ expt dif))
(cond ((or (> r half) (and (= r half) (oddp mant)))
{-- hmmm, does rounding want to do the same thing
if the mantissa is negative?}
(setq mant (1+ mant))
(or (= (floormat-haulong mant) digits-wanted)
dont-move-decimal-point-offset?
(setq mant (// mant 10.) expt (1+ expt)))))))
(setf (floormat-mant) (* mant msign))
(setf (floormat-expt) expt)
(setf (floormat-sigdig) digits-wanted)
floormat)
;;;; Hack with numerical limitations
(define-private-xmacro (floormat-max-expt&)
''#.(loop for i from 5 when (bigp (expt 10. i)) return (1- i)))
(define-private-xmacro (floormat-flonum-digits-guess)
''#.(loop for i from 1
as test = (float (expt 10. i))
when (= test (1+$ test)) return i))
(define-private-xmacro (floormat-testable-rangep positive-flonum)
(auxs ((flonum centered-flonum)
(float (↑ 10. (floormat-flonum-digits-guess))))
((flonum range-guess)
(float (↑ 10. (1- (floormat-max-expt&))))))
`(lessp ,(//$ centered-flonum range-guess)
,positive-flonum
,(*$ centered-flonum range-guess)))
(define-private-xmacro (floormat-zero-tsigdig)
'(floormat-flonum-digits-guess))
(define-private-xmacro (floormat-max-expt$)
; Presumes float will give arithmetic overflow error which errset
; will trap.
''#.((lambda (size dummy)
(errset (loop for i from 15.
do (setq dummy (float (expt 10. i)) size i))
nil)
size)
0 ()))
;;;; Dissect a flonum
(define-hidden-hack (floormat-dissect original-x) float
(dcls (returnable))
(bindq (flonum original-x$) (float original-x))
(bindq (flonum x) original-x$
(fixnum mantissa) 0
(fixnum expt) 0
(fixnum sigdig) 0
(fixnum tsigdig) 0
(fixnum msign) 1)
{-- Once upon a time, some of this code came from LMIO;PRINT.}
{-- What this code does is essentially to multiply or divide the
flonum until we get it into a range such that doing a FIX on it
will return a fixnum containing all the significant digits.
There is various crockery having to do with keeping things
in fixnum range, at least for the Maclisp implementation.
We do this, returning that as the mantissa, the exponent being
the number of multiplications or divisions we did. The returned
things are such that (*$ (float mantissa) (↑$ 10.0 expt)) should
equal (in theory) the original number. The sigdig is the number
of digits in the mantissa. tsigdig is the number of "true"
sigdig in the number, that is, the number of digit positions such
that a single-digit change in the last position makes no numerical
difference in the floating-point representation.
None of this will work if flonums have more significant decimal
digits than can be put into a fixnum, unless much if not all of
the arithmetic here is generic; in that case it will fixnum-cons
its balls off.
}
(cond ((zerop x)
(return (make-floormat
mant 0 expt 0 sigdig 1
tsigdig (floormat-flonum-digits-guess))))
((minusp x)
(setq msign -1 x (-$ x))))
(cond ((not (floormat-testable-rangep x))
; Is the number in a range we can hack? If not, we must
; adjust it.
(setq expt (- (fix (//$ (log x) #.(log 10.0)))
(floormat-flonum-digits-guess)))
(setq x (cond ((not (> (abs expt) (floormat-max-expt&)))
(if (minusp expt)
(*$ x (float (↑ 10. (- expt))))
(//$ x (float (↑ 10. expt)))))
((zerop expt) (break barf))
((plusp expt) (//$ x (float (expt 10. expt))))
((plusp (+ (floormat-max-expt$) expt))
(*$ x (float (expt 10. (- expt)))))
('t (*$ x
#.(float (expt 10. (floormat-max-expt$)))
(float (expt 10. (- (+ (floormat-max-expt$)
expt))))))))))
(if (= x (1+$ x))
(loop as div fixnum = 10. then (* div 10.)
as y flonum = (//$ x (float div))
when (not (= y (1+$ y)))
; Back off one
do (or (= div 10.) (setq x (//$ x (float (// div 10.)))))
and return ()
do (setq expt (1+ expt)))
; Iterate until the digit just to the left of the decimal point
; becomes insignificant.
(loop as pwr fixnum = 10. then (* pwr 10.)
as y flonum = (*$ x (float pwr))
do (setq expt (1- expt))
when (= y (1+$ y)) do (setq x y) and return ()))
(setq mantissa (// (+ (fix x) 5) 10.) expt (1+ expt))
(setq tsigdig (setq sigdig (floormat-haulong mantissa)))
(loop while (zerop (\ mantissa 10.))
do (setq mantissa (// mantissa 10.)
expt (1+ expt)
sigdig (1- sigdig)))
(make-floormat mant (* mantissa msign)
expt expt
sigdig sigdig
tsigdig tsigdig))
;;;; Random output frobs
(define-hidden-hack (floormat-fixnum-quickly (fixnum n)) float
(and (> n 9.) (floormat-fixnum-quickly (// n 10.)))
(format-tyo-digit (\ n 10.)))
(define-private-xmacro (floormat-tyo-E)
'(format-tyo {(only-for Multics) #/e} {(except-for Multics) #/E}))
(define-hidden-hack (floormat-fixnum
(fixnum n) (fixnum digits) truncate-trailing-zeros?)
float
(loop as factor fixnum = (↑ 10. digits) then next-factor
as next-factor fixnum = (// factor 10.)
as firstp = 't then ()
when truncate-trailing-zeros?
unless firstp
when (zerop (\ n factor))
return ()
while (plusp next-factor)
do (format-tyo-digit (\ (// n next-factor) 10.))))
;;;; ~F - "free" format
(define-autoload-op F (params arg) float
(if (and (null params) (not colon-flag))
(format-princ (float arg))
(let ((floormat (floormat-dissect arg)))
(and (car params)
(floormat-resize
floormat
(floormat-min& (car params) (floormat-tsigdig))
()))
(format-justify
'left (caddr params) () () (cadddr (cdr params))
'floormat-F floormat (cadr params) (cadddr params)
(lbind (((fixnum mant) (floormat-mant)))
(cond ((minusp mant) (setf (floormat-mant) (- mant)) #/-)
(atsign-flag #/+)))
colon-flag))))
(define-hidden-hack (floormat-F floormat dpos? lpad? signp show-significancep)
float
(dcls (returnable))
(bindq (character-code lpad) (if lpad? (format-character lpad?) #\sp)
(fixnum mant) (floormat-mant)
(fixnum expt) (floormat-expt)
(fixnum sigdig) (floormat-sigdig))
(bindq (fixnum dpos) (if (null dpos?) 1
(floormat-min& (floormat-max& dpos? 1)
(1- sigdig))))
(bindq (fixnum ldig) (+ sigdig expt) (fixnum rdig) (- expt))
(cond ((or (and dpos? (> ldig dpos)) ; can't fit it in the field!
(< (- ldig dpos) -2)
(not (< ldig sigdig)))
(return (floormat-FE floormat dpos lpad
signp show-significancep))))
(format-repeat-char lpad (- (floormat-min& (- dpos ldig) (1- dpos))
(if signp 1 0)))
(and signp (format-tyo signp))
(cond ((plusp ldig)
(floormat-fixnum
(// mant (↑ 10. (floormat-max& rdig 0)))
(floormat-min& ldig sigdig)
())
(and (> ldig sigdig) (format-repeat-char #/0 (- ldig sigdig))))
('t (format-tyo #/0)))
(format-tyo #/.)
(cond ((minusp rdig) (format-tyo #/0))
('t (format-repeat-char #/0 (- rdig sigdig))
(floormat-fixnum
mant (floormat-min& rdig sigdig) (not show-significancep)))))
(define-hidden-hack (floormat-FE
floormat (fixnum dpos) (fixnum lpad)
signp show-significancep)
float
(bindq (fixnum mant) (floormat-mant)
(fixnum expt) (floormat-expt)
(fixnum sigdig) (floormat-sigdig))
(cond (signp
(format-tyo signp)
(and (> dpos 1) (setq dpos (1- dpos)))))
(bindq (fixnum d) (- sigdig dpos))
(bindq (fixnum factor) (↑ 10. d))
(floormat-fixnum (// mant factor) dpos ())
(format-tyo #/.)
(floormat-fixnum (\ mant factor) d (not show-significancep))
(floormat-tyo-E)
(format-tyo (cond ((minusp (setq expt (+ expt d)))
(setq expt (- expt)) #/-)
('t #/+)))
(floormat-fixnum-quickly expt))
{(divert-documentation-to ops)
.item ~F
outputs ε2argε* in free-format floating-point. ε3~ε2nε*Fε*
outputs ε2argε* showing at most ε2nε* digits. ε3~ε2nε*:Fε*
will show exactly ε2nε* digits. No other variations are guaranteed
at this time; neither is the ε2exactε* interpretation of ε2nε*.
It is reasonable to use this, however, when one desires to print a
flonum without showing lots of insignificant trailing digits; for
example,
.lisp
(format nil "~6f" 259.258995) => "259.259"
.end←lisp
}
;;;; ~E - exponential format
(define-autoload-op E (params arg) float
; sigdig, ldig, dpos, exptdig, exptmodulus, padchar
(bindq floormat (floormat-dissect arg))
(and (car params) (floormat-resize floormat (car params) ()))
(bindq (fixnum mant) (floormat-mant)
(fixnum expt) (floormat-expt)
(fixnum sigdig) (floormat-sigdig))
(bindq (fixnum ldig) (or (car (setq params (cdr params))) 1)
(fixnum dpos) (or (car (setq params (cdr params))) 1)
(fixnum exptdig) (or (car (setq params (cdr params))) 1)
(fixnum exptmodulus) (or (car (setq params (cdr params))) 1)
padchar (or (car (setq params (cdr params))) #/0)
signp (cond ((minusp mant) (setq mant (- mant)) #/-)
(atsign-flag #/+)))
(bindq (fixnum realldig)
(+ (\ (+ (\ (+ expt (- sigdig ldig)) exptmodulus) exptmodulus)
exptmodulus)
ldig))
(bindq (fixnum realrdig) (- sigdig realldig))
(bindq (fixnum realexpt) (+ expt realrdig))
(cond ((not (null signp))
(setq dpos (1- dpos))
(cond (colon-flag (format-tyo signp) (setq signp ())))))
(format-repeat-char padchar (- dpos realldig))
(and signp (format-tyo signp))
(bindq factor (↑ 10. realrdig))
(floormat-fixnum-quickly (// mant factor))
(format-tyo #/.)
(floormat-fixnum mant realrdig ())
(floormat-tyo-E)
(format-tyo (cond ((minusp realexpt) (setq realexpt (- realexpt)) #/-)
('t #/+)))
(format-repeat-char #/0 (- exptdig (floormat-haulong realexpt)))
(floormat-fixnum-quickly realexpt)
)
{(divert-documentation-to ops)
.item ~E
Outputs ε2argε* in exponential notation; e.g., ε3"2.59259e+2"ε*.
ε3~ε2nε*Eε* interprets ε2nε* the same as ε3~Fε*. No other
parameters or flags are guaranteed at this time.
}
;;;; ~$ - fixed decimal field
(define-autoload-op /$ (params arg) float
(bindq (flonum newarg) (float arg) signp ())
(cond (colon-flag
(cond ((minusp newarg)
(setq newarg (-$ newarg)) (format-tyo #/-))
(atsign-flag (format-tyo #/+))))
((or atsign-flag (minusp newarg)) (setq signp 't)))
(format-justify
'right (caddr params) () () (cadddr params) #'floormat-money
newarg (or (car params) 2) (or (cadr params) 1) signp))
(define-hidden-hack (floormat-money
arg (fixnum rdigits) (fixnum ldigits) signp)
float
(bindq floormat (floormat-dissect arg))
(cond ((< rdigits (- (floormat-expt)))
; Truncate if necessary.
(lbind (((fixnum new)
(+ (floormat-sigdig) (floormat-expt) rdigits)))
(if (plusp new) (floormat-resize floormat new 't)
(setq floormat (floormat-dissect 0.0))))))
(bindq (fixnum mant) (floormat-mant)
(fixnum expt) (floormat-expt)
(fixnum sigdig) (floormat-sigdig))
(bindq (fixnum real-ldig) (+ sigdig expt) (fixnum real-rdig) (- expt))
(cond ((minusp mant) (setq mant (- mant)) (and signp (format-tyo #/-)))
(signp (format-tyo #/+)))
(and (> ldigits real-ldig)
(format-repeat-char
#/0 (if (plusp real-ldig) (- ldigits real-ldig) ldigits)))
(cond ((> real-ldig sigdig)
(floormat-fixnum mant sigdig ())
(format-repeat-char #/0 (- real-ldig sigdig)))
('t (floormat-fixnum (// mant (↑ 10. real-rdig)) real-ldig ())))
(format-tyo #/.)
(cond ((plusp real-rdig)
(cond ((> real-rdig sigdig)
(format-repeat-char #/0 (- real-rdig sigdig))
(setq real-rdig sigdig)))
(floormat-fixnum mant real-rdig ())
(format-repeat-char #/0 (- rdigits real-rdig)))
('t (format-repeat-char #/0 rdigits)))
())
{(divert-documentation-to ops)
.item ~$
(That's a dollar sign.)
ε3~ε2rdigε*,ε2ldigε*,ε2fieldε*,ε2padcharε*$ε* prints
ε2argε*, a flonum, with exactly ε2rdigε* digits after the decimal
point (default is 2), at least ε2ldigε* digits preceding the
decimal point (default is 1), right justified in a field ε2fieldε*
columns long, padded out with ε2padcharε*. The colon modifier says
that we should cause the sign character to be left justified in the
field. The atsign modifier says that we should always output the
sign character. The ε2ldigε* allows one to specify a portion of
the number which does not get zero suppressed.
}
;;;; FERROR (Multix)
{(only-for Multics)
(declare (special args))
(define-public-routine (ferror condition-name format-string
(any-number-of format-args))
(and (or (not condition-name)
(not (apply 'signal (list* condition-name nil nil '?
format-string format-args))))
((lambda (args)
(error (format-internal 'string format-string format-args)))
(list* 'ferror condition-name format-string format-args))))
}
;;;; Patch documentation files
{(divert-documentation-to ops)
.c Throw this in here for good measure
.item ~\
This is not really an operator. If one desires to use a
multi-character ε3formatε* operator, it may be placed within
backslashes, as in ε3~\now\ε* for the ε3nowε* operator. See
⊗(multi-character-operator-page).
.end←table
}
{(divert-documentation-to chart)
.item ~\ε2nameε*\
Call multi-character operator ε2nameε*.
.end←table
}
(sstatus feature format)